Keep track of result source instance ancestry

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSource.pm

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index a7645ef..0a5d1fc 100644 (file)
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -4,25 +4,30 @@ use strict;
 use warnings;
 
 use base 'DBIx::Class::ResultSource::RowParser';
-use mro 'c3';
 
 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;
 
 use namespace::clean;
 
-__PACKAGE__->mk_group_accessors(simple => qw/
-  source_name name source_info
-  _ordered_columns _columns _primaries _unique_constraints
-  _relationships resultset_attributes
-  column_info_from_storage sqlt_deploy_callback
-/);
+my @hashref_attributes = qw(
+  source_info resultset_attributes
+  _columns _unique_constraints _relationships
+);
+my @arrayref_attributes = qw(
+  _ordered_columns _primaries
+);
+__PACKAGE__->mk_group_accessors(simple =>
+  @hashref_attributes,
+  @arrayref_attributes,
+  qw( source_name name column_info_from_storage sqlt_deploy_callback ),
+);
 
 __PACKAGE__->mk_group_accessors(component_class => qw/
   resultset_class
@@ -116,20 +121,128 @@ Creates a new ResultSource object.  Not normally called directly by end users.
 
 =cut
 
-sub new {
-  my ($class, $attrs) = @_;
-  $class = ref $class if ref $class;
-
-  my $new = bless { %{$attrs || {}} }, $class;
-  $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
-  $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
-  $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
-  $new->{_columns} = { %{$new->{_columns}||{}} };
-  $new->{_relationships} = { %{$new->{_relationships}||{}} };
-  $new->{name} ||= "!!NAME NOT SET!!";
-  $new->{_columns_info_loaded} ||= 0;
-  $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
-  return $new;
+{
+  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 $ancestor = delete $attrs->{__derived_from};
+
+    my $self = bless { %$attrs }, $class;
+
+
+    DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+      and
+    # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything
+    ( not ( keys(%$self) == 1 and exists $self->{name} ) )
+      and
+    defined CORE::caller(1)
+      and
+    (CORE::caller(1))[3] !~ / ::new$ | ^ DBIx::Class :: (?:
+      ResultSourceProxy::Table::table
+        |
+      ResultSourceProxy::Table::_init_result_source_instance
+        |
+      ResultSource::clone
+    ) $ /x
+      and
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1
+      and
+    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;
+    $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
+
+    $self->{$_} = { %{ $self->{$_} || {} } }
+      for @hashref_attributes;
+
+    $self->{$_} = [ @{ $self->{$_} || [] } ]
+      for @arrayref_attributes;
+
+    $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
+
+  $rsrc_instance->clone( atribute_name => overriden_value );
+
+A wrapper around L</new> inheriting any defaults from the callee. This method
+also not normally invoked directly by end users.
+
+=cut
+
+sub clone {
+  my $self = shift;
+
+  $self->new({
+    (
+      (length ref $self)
+        ? ( %$self, __derived_from => $self )
+        : ()
+    ),
+    (
+      (@_ == 1 and ref $_[0] eq 'HASH')
+        ? %{ $_[0] }
+        : @_
+    ),
+  });
 }
 
 =pod