From: Peter Rabbitson Date: Fri, 12 Aug 2011 15:22:52 +0000 (+0200) Subject: Cleanup compose_namespace(), clarify leaktests wrt classdata X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dee99c2433a9f090cba9dd0349459a1df0b25c3a;p=dbsrgits%2FDBIx-Class-Historic.git Cleanup compose_namespace(), clarify leaktests wrt classdata --- diff --git a/lib/DBIx/Class/Carp.pm b/lib/DBIx/Class/Carp.pm index 002b6e2..6bec374 100644 --- a/lib/DBIx/Class/Carp.pm +++ b/lib/DBIx/Class/Carp.pm @@ -31,7 +31,6 @@ sub __find_caller { while (@f = caller($fr_num++)) { last unless $f[0] =~ $skip_pattern; - # if ( $f[0]->can('_skip_namespace_frames') and diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 1959f40..5b86fec 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -196,17 +196,16 @@ sub _map_namespaces { # returns the result_source_instance for the passed class/object, # or dies with an informative message (used by load_namespaces) sub _ns_get_rsrc_instance { - my $class = shift; - my $rs = ref ($_[0]) || $_[0]; - - if ($rs->can ('result_source_instance') ) { - return $rs->result_source_instance; - } - else { - $class->throw_exception ( - "Attempt to load_namespaces() class $rs failed - are you sure this is a real Result Class?" + my $me = shift; + my $rs_class = ref ($_[0]) || $_[0]; + + return try { + $rs_class->result_source_instance + } catch { + $me->throw_exception ( + "Attempt to load_namespaces() class $rs_class failed - are you sure this is a real Result Class?: $_" ); - } + }; } sub load_namespaces { @@ -400,7 +399,6 @@ sub load_classes { foreach my $to (@to_register) { $class->register_class(@$to); - # if $class->can('result_source_instance'); } } @@ -831,7 +829,7 @@ sub connection { } catch { $self->throw_exception( - "No arguments to load_classes and couldn't load ${storage_class} ($_)" + "Unable to load storage class ${storage_class}: $_" ); }; my $storage = $storage_class->new($self=>$args); @@ -905,40 +903,51 @@ will produce the output sub compose_namespace { my ($self, $target, $base) = @_; + my $schema = $self->clone; + + $schema->source_registrations({}); + + # the original class-mappings must remain - otherwise + # reverse_relationship_info will not work + #$schema->class_mappings({}); + { no warnings qw/redefine/; local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO; use warnings qw/redefine/; no strict qw/refs/; - foreach my $moniker ($schema->sources) { - my $source = $schema->source($moniker); + foreach my $moniker ($self->sources) { + my $orig_source = $self->source($moniker); + my $target_class = "${target}::${moniker}"; - $self->inject_base( - $target_class => $source->result_class, ($base ? $base : ()) + $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); + + # register_source examines result_class, and then returns us a clone + my $new_source = $schema->register_source($moniker, bless + { %$orig_source, result_class => $target_class }, + ref $orig_source, ); - $source->result_class($target_class); - if ($target_class->can('result_source_instance')) { - # since the newly created classes are registered only with - # the instance of $schema, it should be safe to weaken - # the ref (it will GC when $schema is destroyed) - $target_class->result_source_instance($source); - weaken ${"${target_class}::__cag_result_source_instance"}; + if ($target_class->can('result_source_instance')) { + # give the class a schema-less source copy + $target_class->result_source_instance( bless + { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, + ref $new_source, + ); } - $schema->register_source($moniker, $source); } - } - Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; - { - no strict 'refs'; - no warnings 'redefine'; + foreach my $meth (qw/class source resultset/) { + no warnings 'redefine'; *{"${target}::${meth}"} = subname "${target}::${meth}" => sub { shift->schema->$meth(@_) }; } } + + Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + return $schema; } @@ -1035,6 +1044,7 @@ sub clone { $clone->register_extra_source($moniker => $new); } $clone->storage->set_schema($clone) if $clone->storage; + return $clone; } @@ -1319,11 +1329,7 @@ moniker. =cut -sub register_source { - my $self = shift; - - $self->_register_source(@_); -} +sub register_source { shift->_register_source(@_) } =head2 unregister_source @@ -1337,11 +1343,7 @@ Removes the L from the schema for the given moniker. =cut -sub unregister_source { - my $self = shift; - - $self->_unregister_source(@_); -} +sub unregister_source { shift->_unregister_source(@_) } =head2 register_extra_source @@ -1356,42 +1358,44 @@ has a source and you want to register an extra one. =cut -sub register_extra_source { - my $self = shift; - - $self->_register_source(@_, { extra => 1 }); -} +sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $moniker, $source, $params) = @_; - my $orig_source = $source; - $source = $source->new({ %$source, source_name => $moniker }); + $source->schema($self); weaken $source->{schema} if ref($self); - my $rs_class = $source->result_class; - my %reg = %{$self->source_registrations}; $reg{$moniker} = $source; $self->source_registrations(\%reg); - return if ($params->{extra}); - return unless defined($rs_class) && $rs_class->can('result_source_instance'); - - my %map = %{$self->class_mappings}; - if ( - exists $map{$rs_class} - and - $map{$rs_class} ne $moniker - and - $rs_class->result_source_instance ne $orig_source - ) { - carp "$rs_class already has a source, use register_extra_source for additional sources"; + return $source if $params->{extra}; + + my $rs_class = $source->result_class; + if ($rs_class and my $rsrc = try { $rs_class->result_source_instance } ) { + my %map = %{$self->class_mappings}; + if ( + exists $map{$rs_class} + and + $map{$rs_class} ne $moniker + and + $rsrc ne $_[2] # orig_source + ) { + carp + "$rs_class already had a registered source which was replaced by this call. " + . 'Perhaps you wanted register_extra_source(), though it is more likely you did ' + . 'something wrong.' + ; + } + + $map{$rs_class} = $moniker; + $self->class_mappings(\%map); } - $map{$rs_class} = $moniker; - $self->class_mappings(\%map); + + return $source; } { diff --git a/t/100extra_source.t b/t/100extra_source.t index b917958..490bbec 100644 --- a/t/100extra_source.t +++ b/t/100extra_source.t @@ -55,7 +55,7 @@ warnings_like ( isa_ok ($schema->resultset('Artist'), 'DBIx::Class::ResultSet'); }, [ - qr/DBICTest::Artist already has a source, use register_extra_source for additional sources/ + qr/DBICTest::Artist already had a registered source which was replaced by this call/ ], 'registering source to an existing result warns' ); diff --git a/t/52leaks.t b/t/52leaks.t index 1a052ef..5614252 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -36,9 +36,10 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) { use lib qw(t/lib); use DBICTest::RunMode; use DBIx::Class; +use B 'svref_2object'; BEGIN { plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test" - if DBIx::Class::_ENV_::PEEPEENESS(); + if DBIx::Class::_ENV_::PEEPEENESS; } use Scalar::Util qw/refaddr reftype weaken/; @@ -121,6 +122,7 @@ unless (DBICTest::RunMode->is_plain) { %$weak_registry = (); } +my @compose_ns_classes; { use_ok ('DBICTest'); @@ -128,6 +130,8 @@ unless (DBICTest::RunMode->is_plain) { my $rs = $schema->resultset ('Artist'); my $storage = $schema->storage; + @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations}; + ok ($storage->connected, 'we are connected'); my $row_obj = $rs->search({}, { rows => 1})->next; # so that commits/rollbacks work @@ -267,6 +271,7 @@ unless (DBICTest::RunMode->is_plain) { reftype $phantom, refaddr $phantom, ); + $weak_registry->{$slot} = $phantom; weaken $weak_registry->{$slot}; } @@ -300,25 +305,32 @@ for my $slot (keys %$weak_registry) { } } - -# FIXME -# For reasons I can not yet fully understand the table() god-method (located in -# ::ResultSourceProxy::Table) attaches an actual source instance to each class -# as virtually *immortal* class-data. -# For now just ignore these instances manually but there got to be a saner way -for ( map { $_->result_source_instance } ( +# every result class has a result source instance as classdata +# make sure these are all present and distinct before ignoring +# (distinct means only 1 reference) +for my $rs_class ( 'DBICTest::BaseResult', + @compose_ns_classes, map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources -)) { - delete $weak_registry->{$_}; +) { + # need to store the SVref and examine it separately, to push the rsrc instance off the pad + my $SV = svref_2object($rs_class->result_source_instance); + is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" ); + + # ignore it + delete $weak_registry->{$rs_class->result_source_instance}; } -# FIXME -# same problem goes for the schema - its classdata contains live result source -# objects, which to add insult to the injury are *different* instances from the -# ones we ignored above -for ( values %{DBICTest::Schema->source_registrations || {}} ) { - delete $weak_registry->{$_}; +# Schema classes also hold sources, but these are clones, since +# each source contains the schema (or schema class name in this case) +# Hence the clone so that the same source can be registered with +# multiple schemas +for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) { + + my $SV = svref_2object(DBICTest::Schema->source($moniker)); + is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" ); + + delete $weak_registry->{DBICTest::Schema->source($moniker)}; } for my $slot (sort keys %$weak_registry) { @@ -337,7 +349,6 @@ for my $slot (sort keys %$weak_registry) { }; } - # we got so far without a failure - this is a good thing # now let's try to rerun this script under a "persistent" environment # this is ugly and dirty but we do not yet have a Test::Embedded or