From: Peter Rabbitson Date: Wed, 15 Jan 2014 15:04:24 +0000 (+0100) Subject: Switch to a global symtable "classdata" visitor X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=556c4fe6;p=dbsrgits%2FDBIx-Class-Historic.git Switch to a global symtable "classdata" visitor This not only allows us to track anything global, not only CAG stuff but also removes a bunch of workarounda from t/52leaks.t \o/ --- diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index fda633a..23ffebe 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -216,10 +216,10 @@ my $reqs = { } }, - test_leaks => { + test_leaks_heavy => { req => { - 'Test::Memory::Cycle' => '0', - 'Devel::Cycle' => '1.10', + 'Class::MethodCache' => '0.02', + 'PadWalker' => '1.06', }, }, diff --git a/t/52leaks.t b/t/52leaks.t index 07f57b7..bb375a3 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -295,23 +295,6 @@ unless (DBICTest::RunMode->is_plain) { $base_collection->{"DBI handle $_"} = $_; } - SKIP: { - if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) { - my @w; - local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ }; - - Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection'); - - if ( $] > 5.011 ) { - local $TODO = 'Silence warning due to RT56681'; - is (@w, 0, 'No Devel::Cycle emitted warnings'); - } - } - else { - skip 'Circular ref test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1; - } - } - populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_") for keys %$base_collection; } @@ -361,25 +344,11 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } - elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) { - # Moo keeps globals around, this is normal - delete $weak_registry->{$addr}; - } - elsif ($names =~ /^SQL::Translator::Generator::DDL::SQLite/m) { - # SQLT::Producer::SQLite keeps global generators around for quoted - # and non-quoted DDL, allow one for each quoting style - delete $weak_registry->{$addr} - unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++; - } elsif ($names =~ /^Hash::Merge/m) { # only clear one object of a specific behavior - more would indicate trouble delete $weak_registry->{$addr} unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++; } - elsif ($names =~ /^DateTime::TimeZone/m) { - # DT is going through a refactor it seems - let it leak zones for now - delete $weak_registry->{$addr}; - } } # FIXME !!! diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 794e83f..f3cf859 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -6,8 +6,12 @@ use strict; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); use DBIx::Class::_Util 'refcount'; +use DBIx::Class::Optional::Dependencies; use Data::Dumper::Concise; use DBICTest::Util 'stacktrace'; +use constant { + CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), +}; use base 'Exporter'; our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr); @@ -95,15 +99,61 @@ sub CLONE { } } +sub visit_refs { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + $args->{seen_refs} ||= {}; + + my $visited_cnt = '0E0'; + for my $i (0 .. $#{$args->{refs}} ) { + next if isweak($args->{refs}[$i]); + + my $r = $args->{refs}[$i]; + + next unless length ref $r; + + next if $args->{seen_refs}{my $dec_addr = Scalar::Util::refaddr($r)}++; + + $visited_cnt++; + $args->{action}->($r) or next; + + my $type = reftype $r; + if ($type eq 'HASH') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($r->{$_}) ) ? $r->{$_} : () + } keys %$r ] }); + } + elsif ($type eq 'ARRAY') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($r->[$_]) ) ? $r->[$_] : () + } 0..$#$r ] }); + } + elsif ($type eq 'REF' and !isweak($$r)) { + $visited_cnt += visit_refs({ %$args, refs => [ $$r ] }); + } + elsif (CV_TRACING and $type eq 'CODE') { + $visited_cnt += visit_refs({ %$args, refs => [ map { + ( !isweak($_) ) ? $_ : () + } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269 + } + } + $visited_cnt; +} + sub assert_empty_weakregistry { my ($weak_registry, $quiet) = @_; + # in case we hooked bless any extra object creation will wreak + # havoc during the assert phase + local *CORE::GLOBAL::bless; + *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) }; + croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; return unless keys %$weak_registry; my $tb = eval { Test::Builder->new } - or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; + or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense"; for my $addr (keys %$weak_registry) { $weak_registry->{$addr}{display_name} = join ' | ', ( @@ -116,58 +166,59 @@ sub assert_empty_weakregistry { if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} ); } - # 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->{hrefaddr $_[0]}++; - - $classdata_refcounts->{hrefaddr $_[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 { $_ =~ /(?{$pkg} += visit_refs ( + seen_refs => $seen_refs, + action => sub { ++$classdata_refs->{hrefaddr $_[0]} }, + refs => [ map { my $sym = $_; + # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there + ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ), + + ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) ) + ? ${"$pkg$sym"} : () + , + ( map { + ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) ) + ? *{"$pkg$sym"}{$_} + : () + } qw(HASH ARRAY IO GLOB) ), + } keys %$pkg ], + ) unless $pkg =~ /^ :: (?: + DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 + ) :: $/x; + + $symwalker->("${pkg}$_") for grep { $_ =~ /(?(); - for my $refaddr (keys %$weak_registry) { - if ( - defined $weak_registry->{$refaddr}{weakref} - and - my $expected_refcnt = $classdata_refcounts->{$refaddr} - ) { - delete $weak_registry->{$refaddr} - if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt; - } - } +# use Devel::Dwarn; +# Ddie [ map +# { { $_ => $symcounts->{$_} } } +# sort +# {$symcounts->{$a} <=> $symcounts->{$b} } +# keys %$symcounts +# ]; } + delete $weak_registry->{$_} for keys %$classdata_refs; + for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { next if ! defined $weak_registry->{$addr}{weakref}; @@ -188,7 +239,7 @@ sub assert_empty_weakregistry { ; }; - $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n" + $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); $diag =~ s/^/ /mg;