From: Peter Rabbitson Date: Mon, 29 Jul 2013 04:45:50 +0000 (+0200) Subject: Move classdata handling to DBICTest::Util::LeakTracer X-Git-Tag: v0.08260~123 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8fa57d17d30acafcdde55238ae5355b58e0c60e2;p=dbsrgits%2FDBIx-Class.git Move classdata handling to DBICTest::Util::LeakTracer --- diff --git a/t/52leaks.t b/t/52leaks.t index 9f8c71a..4923be0 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -50,7 +50,6 @@ use DBICTest::RunMode; use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use Scalar::Util 'refaddr'; 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; @@ -117,7 +116,6 @@ unless (DBICTest::RunMode->is_plain) { %$weak_registry = (); } -my @compose_ns_classes; { use_ok ('DBICTest'); @@ -125,8 +123,6 @@ my @compose_ns_classes; 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 @@ -385,34 +381,6 @@ for my $slot (keys %$weak_registry) { } } -# 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 -) { - # 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}; -} - -# 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)}; -} - # FIXME !!! # There is an actual strong circular reference taking place here, but because # half of it is in XS no leaktracer sees it, and Devel::FindRef is equally diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index d0e63f2..2c10000 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -5,6 +5,7 @@ use strict; use Carp; use Scalar::Util qw/isweak weaken blessed reftype refaddr/; +use B 'svref_2object'; use DBICTest::Util 'stacktrace'; use base 'Exporter'; @@ -20,23 +21,28 @@ sub populate_weakregistry { croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; croak 'Target is not a reference' unless length ref $target; + my $refaddr = refaddr $target; + $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification (defined blessed $target) ? blessed($target) . '=' : '', reftype $target, - refaddr $target, + $refaddr, ); if (defined $weak_registry->{$slot}{weakref}) { - if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) { - print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n"; + if ( $weak_registry->{$slot}{refaddr} != $refaddr ) { + print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n"; exit 255; } } else { - $refs_traced++; + $weak_registry->{$slot} = { + stacktrace => stacktrace(1), + refaddr => $refaddr, + renumber => $_[2] ? 0 : 1, + }; weaken( $weak_registry->{$slot}{weakref} = $target ); - $weak_registry->{$slot}{stacktrace} = stacktrace(1); - $weak_registry->{$slot}{renumber} = 1 unless $_[2]; + $refs_traced++; } weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry ) @@ -63,7 +69,9 @@ sub CLONE { my $slot = shift @live_slots; my $inst = shift @live_instances; - $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg + my $refaddr = $inst->{refaddr} = refaddr($inst); + + $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg if $inst->{renumber}; $reg->{$slot} = $inst; @@ -88,6 +96,60 @@ sub assert_empty_weakregistry { } + # compile a list of refs stored as CAG class data, so we can skip them + # intelligently below + my ($classdata_refcounts, $symwalker, $refwalker); + + $refwalker = sub { + return unless length ref $_[0]; + + my $seen = $_[1] || {}; + return if $seen->{refaddr $_[0]}++; + + $classdata_refcounts->{refaddr $_[0]}++; + + my $type = reftype $_[0]; + if ($type eq 'HASH') { + $refwalker->($_, $seen) for values %{$_[0]}; + } + elsif ($type eq 'ARRAY') { + $refwalker->($_, $seen) for @{$_[0]}; + } + elsif ($type eq 'REF') { + $refwalker->($$_, $seen); + } + }; + + $symwalker = sub { + no strict 'refs'; + my $pkg = shift || '::'; + + $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg; + + $symwalker->("${pkg}$_") for grep { $_ =~ /(?(); + + for my $slot (keys %$weak_registry) { + if ( + defined $weak_registry->{$slot}{weakref} + and + my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}} + ) { + # need to store the SVref and examine it separately, + # to push the weakref instance off the pad + my $sv = svref_2object($weak_registry->{$slot}{weakref}); + delete $weak_registry->{$slot} if $sv->REFCNT == $expected_refcnt; + } + } + } + for my $slot (sort keys %$weak_registry) { ! defined $weak_registry->{$slot}{weakref} and next if $quiet;