From: Peter Rabbitson Date: Thu, 14 Apr 2016 07:27:33 +0000 (+0200) Subject: Keep track of result source instance ancestry X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0ff33686;p=dbsrgits%2FDBIx-Class.git Keep track of result source instance ancestry The oddball external registry (instead of directly-linked objects) is due to shit like 31399b48 For now this doesn't realy do anything: See several commits higher why this is needed in the first place. --- diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 4ebb4c0..0a5d1fc 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -9,7 +9,7 @@ use DBIx::Class::Carp; use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Scalar::Util qw/blessed weaken isweak/; +use Scalar::Util qw( blessed weaken isweak refaddr ); # FIXME - somehow breaks ResultSetManager, do not remove until investigated use DBIx::Class::ResultSet; @@ -122,11 +122,23 @@ Creates a new ResultSource object. Not normally called directly by end users. =cut { + my $rsrc_registry; + + sub __derived_instances { + map { + (defined $_->{weakref}) + ? $_->{weakref} + : () + } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } } + } + sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $self = bless { %{$attrs || {}} }, $class; + my $ancestor = delete $attrs->{__derived_from}; + + my $self = bless { %$attrs }, $class; DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE @@ -149,6 +161,39 @@ Creates a new ResultSource object. Not normally called directly by end users. Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead"); + my $own_slot = $rsrc_registry->{ + my $own_addr = refaddr $self + } = { derivatives => {} }; + + weaken( $own_slot->{weakref} = $self ); + + if( + length ref $ancestor + and + my $ancestor_slot = $rsrc_registry->{ + my $ancestor_addr = refaddr $ancestor + } + ) { + + # on ancestry recording compact registry slots, prevent unbound growth + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + defined $r->{$_}{weakref} or delete $r->{$_} + for keys %$r; + } + + weaken( $_->{$own_addr} = $own_slot ) for map + { $_->{derivatives} } + ( + $ancestor_slot, + (grep + { defined $_->{derivatives}{$ancestor_addr} } + values %$rsrc_registry + ), + ) + ; + } + + $self->{resultset_class} ||= 'DBIx::Class::ResultSet'; $self->{name} ||= "!!NAME NOT SET!!"; $self->{_columns_info_loaded} ||= 0; @@ -162,6 +207,16 @@ Creates a new ResultSource object. Not normally called directly by end users. $self; } + + sub DBIx::Class::__Rsrc_Ancestry_iThreads_handler__::CLONE { + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + %$r = map { + defined $_->{weakref} + ? ( refaddr $_->{weakref} => $_ ) + : () + } values %$r + } + } } =head2 clone @@ -179,7 +234,7 @@ sub clone { $self->new({ ( (length ref $self) - ? %$self + ? ( %$self, __derived_from => $self ) : () ), ( diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index c165f77..a1a0ce3 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -30,6 +30,10 @@ sub _init_result_source_instance { $class->ensure_class_loaded($table_class); if( $rsrc ) { + # + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # $rsrc = $table_class->new({ %$rsrc, result_class => $class, @@ -84,14 +88,22 @@ sub table { unless (blessed $table && $table->isa($class->table_class)) { + my $ancestor = $class->can('result_source_instance') + ? $class->result_source_instance + : undef + ; + my $table_class = $class->table_class; $class->ensure_class_loaded($table_class); + + # NOTE! - not using clone() here and *NOT* marking source as derived + # from the one already existing on the class (if any) + # This is logically sound as we are operating at class-level, and is + # in fact necessary, as otherwise any base-class with a "dummy" table + # will be marked as an ancestor of everything $table = $table_class->new({ - $class->can('result_source_instance') - ? %{$class->result_source_instance||{}} - : () - , + %{ $ancestor || {} }, name => $table, result_class => $class, }); diff --git a/xt/extra/internals/rsrc_ancestry.t b/xt/extra/internals/rsrc_ancestry.t new file mode 100644 index 0000000..e39f005 --- /dev/null +++ b/xt/extra/internals/rsrc_ancestry.t @@ -0,0 +1,82 @@ +use warnings; +use strict; + +use Config; +BEGIN { + my $skipall; + + if( ! $Config{useithreads} ) { + $skipall = 'your perl does not support ithreads'; + } + elsif( "$]" < 5.008005 ) { + $skipall = 'DBIC does not actively support threads before perl 5.8.5'; + } + elsif( $INC{'Devel/Cover.pm'} ) { + $skipall = 'Devel::Cover does not work with ithreads yet'; + } + + if( $skipall ) { + print "1..0 # SKIP $skipall\n"; + exit 0; + } +} + +use threads; +use Test::More; +use DBIx::Class::_Util 'hrefaddr'; +use Scalar::Util 'weaken'; + +{ + package DBICTest::Ancestry::Result; + + use base 'DBIx::Class::Core'; + + __PACKAGE__->table("foo"); +} + +{ + package DBICTest::Ancestry::Schema; + + use base 'DBIx::Class::Schema'; + + __PACKAGE__->register_class( r => "DBICTest::Ancestry::Result" ); +} + +my $schema = DBICTest::Ancestry::Schema->clone; +my $rsrc = $schema->resultset("r")->result_source->clone; + +threads->new( sub { + + my $another_rsrc = $rsrc->clone; + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $schema->source("r"), + $rsrc, + $another_rsrc, + ) + ; + + undef $schema; + undef $rsrc; + $another_rsrc->schema(undef); + + is_deeply + refaddrify( DBICTest::Ancestry::Result->result_source_instance->__derived_instances ), + refaddrify( + DBICTest::Ancestry::Schema->source("r"), + $another_rsrc, + ) + ; + + # tasty crashes without this + select( undef, undef, undef, 0.2 ); +})->join; + +sub refaddrify { + [ sort map { hrefaddr $_ } @_ ]; +} + +done_testing;