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
=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
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 qw( _columns _relationships resultset_attributes );
+ for @hashref_attributes;
- $self->{_ordered_columns} = [ @{ $self->{_ordered_columns} || [] } ];
+ $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
$self->new({
(
(length ref $self)
- ? %$self
+ ? ( %$self, __derived_from => $self )
: ()
),
(