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 (file)
--- 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 (file)
--- 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 (file)
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;