X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil%2FLeakTracer.pm;h=645bc24c8f042e3e4fba73227b398522f5d078a6;hb=cbd7f87a859ccbb026af01fe38c832596323f156;hp=10dca61099499f98d2b5f88cde6afcf20952ecfb;hpb=85ad63df4eaa9b308b9ca5a3cd1aa20b9f730312;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 10dca61..645bc24 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -5,28 +5,22 @@ use strict; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util 'refcount'; +use DBIx::Class::_Util qw(refcount hrefaddr refdesc); +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'), + SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0, +}; use base 'Exporter'; -our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr); +our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry visit_refs); my $refs_traced = 0; my $leaks_found = 0; my %reg_of_regs; -sub hrefaddr { sprintf '0x%x', &Scalar::Util::refaddr } - -# so we don't trigger stringification -sub _describe_ref { - sprintf '%s%s(%s)', - (defined blessed $_[0]) ? blessed($_[0]) . '=' : '', - reftype $_[0], - hrefaddr $_[0], - ; -} - sub populate_weakregistry { my ($weak_registry, $target, $note) = @_; @@ -49,6 +43,10 @@ sub populate_weakregistry { for keys %$reg; } + # FIXME/INVESTIGATE - something fishy is going on with refs to plain + # strings, perhaps something to do with the CoW work etc... + return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR'; + if (! defined $weak_registry->{$refaddr}{weakref}) { $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), @@ -58,7 +56,7 @@ sub populate_weakregistry { $refs_traced++; } - my $desc = _describe_ref($target); + my $desc = refdesc $target; $weak_registry->{$refaddr}{slot_names}{$desc} = 1; if ($note) { $note =~ s/\s*\Q$desc\E\s*//g; @@ -95,15 +93,169 @@ sub CLONE { } } +sub visit_refs { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + $args->{seen_refs} ||= {}; + + my $visited_cnt = '0E0'; + for my $i (0 .. $#{$args->{refs}} ) { + + next unless length ref $args->{refs}[$i]; # not-a-ref + + my $addr = hrefaddr $args->{refs}[$i]; + + # no diving into weakregistries + next if $reg_of_regs{$addr}; + + next if $args->{seen_refs}{$addr}++; + $visited_cnt++; + + my $r = $args->{refs}[$i]; + + $args->{action}->($r) or next; + + # This may end up being necessarry some day, but do not slow things + # down for now + #if ( defined( my $t = tied($r) ) ) { + # $visited_cnt += visit_refs({ %$args, refs => [ $t ] }); + #} + + my $type = reftype $r; + + local $@; + eval { + 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 + } + 1; + } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; + } + $visited_cnt; +} + +sub visit_namespaces { + my $args = { (ref $_[0]) ? %{$_[0]} : @_ }; + + my $visited = 1; + + $args->{package} ||= '::'; + $args->{package} = '::' if $args->{package} eq 'main'; + + if ( $args->{action}->($args->{package}) ) { + + my $base = $args->{package}; + $base = '' if $base eq '::'; + + + $visited += visit_namespaces({ %$args, package => $_ }) for map + { $_ =~ /(.+?)::$/ ? "${base}::$1" : () } + grep + { $_ =~ /(? sub { + + no strict 'refs'; + + my $pkg = shift; + $pkg = '' if $pkg eq '::'; + $pkg .= '::'; + + # the unless regex at the end skips some dangerous namespaces outright + # (but does not prevent descent) + $refs_per_pkg->{$pkg} += visit_refs ( + seen_refs => $seen_refs, + + # FIXME FIXME FIXME + # This is so damn odd - if we feed a constsub {1} (or in fact almost + # anything other than the actionsub below, any scalarref will show + # up as a leak, trapped by... something... + # Ideally we should be able to const this to sub{1} and just return + # $seen_refs (in fact it is identical to the dummy list at the end of + # a run here). Alas this doesn't seem to work, so punt for now... + action => sub { ++$dummy_addresslist->{ 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; + } + ); + +# use Devel::Dwarn; +# Ddie [ map +# { { $_ => $refs_per_pkg->{$_} } } +# sort +# {$refs_per_pkg->{$a} <=> $refs_per_pkg->{$b} } +# keys %$refs_per_pkg +# ]; + + $seen_refs; +} + sub assert_empty_weakregistry { my ($weak_registry, $quiet) = @_; + Sub::Defer::undefer_all(); + + # 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'; + defined $weak_registry->{$_}{weakref} or delete $weak_registry->{$_} + for keys %$weak_registry; + 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,89 +268,76 @@ 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); + # the symtable walk is very expensive + # if we are $quiet (running in an END block) we do not really need to be + # that thorough - can get by with only %Sub::Quote::QUOTED + delete $weak_registry->{$_} for $quiet + ? do { + my $refs = {}; + visit_refs ( + # only look at the closed over stuffs + refs => [ grep { length ref $_ } map { values %{$_->[2]} } grep { ref $_ eq 'ARRAY' } values %Sub::Quote::QUOTED ], + seen_refs => $refs, + action => sub { 1 }, + ); + keys %$refs; } - }; - - $symwalker = sub { - no strict 'refs'; - my $pkg = shift || '::'; - - $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg; - - $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; - } - } - } + : ( + # full sumtable walk, starting from :: + keys %{ symtable_referenced_addresses() } + ) + ; for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { - ! defined $weak_registry->{$addr}{weakref} and next if $quiet; + next if ! defined $weak_registry->{$addr}{weakref}; + + $leaks_found++ unless $tb->in_todo; + $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}"); + + my $diag = do { + local $Data::Dumper::Maxdepth = 1; + sprintf "\n%s (refcnt %d) => %s\n", + $weak_registry->{$addr}{display_name}, + refcount($weak_registry->{$addr}{weakref}), + ( + ref($weak_registry->{$addr}{weakref}) eq 'CODE' + and + B::svref_2object($weak_registry->{$addr}{weakref})->XSUB + ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) + ; + }; - $tb->ok (! defined $weak_registry->{$addr}{weakref}, "No leaks of $weak_registry->{$addr}{display_name}") or do { - $leaks_found++; + # FIXME - need to add a circular reference seeker based on the visitor + # (will need a bunch of modifications, punting with just a stub for now) - my $diag = do { - local $Data::Dumper::Maxdepth = 1; - sprintf "\n%s (refcnt %d) => %s\n", - $weak_registry->{$addr}{display_name}, - refcount($weak_registry->{$addr}{weakref}), - ( - ref($weak_registry->{$addr}{weakref}) eq 'CODE' - and - B::svref_2object($weak_registry->{$addr}{weakref})->XSUB - ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) - ; - }; + $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" + if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); - $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n" - if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); + $diag =~ s/^/ /mg; - $diag =~ s/^/ /mg; + if (my $stack = $weak_registry->{$addr}{stacktrace}) { + $diag .= " Reference first seen$stack"; + } - if (my $stack = $weak_registry->{$addr}{stacktrace}) { - $diag .= " Reference first seen$stack"; - } + $tb->diag($diag); + +# if ($leaks_found == 1) { +# # using the fh dumper due to intermittent buffering issues +# # in case we decide to exit soon after (possibly via _exit) +# require Devel::MAT::Dumper; +# local $Devel::MAT::Dumper::MAX_STRING = -1; +# open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!; +# Devel::MAT::Dumper::dumpfh( $fh ); +# close ($fh) or die $!; +# +# use POSIX; +# POSIX::_exit(1); +# } + } - $tb->diag($diag); - }; + if (! $quiet and !$leaks_found and ! $tb->in_todo) { + $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); } } @@ -219,6 +358,21 @@ END { else { $tb->note("Auto checked $refs_traced references for leaks - none detected"); } + +# Disable this until better times - SQLT and probably other things +# still load strictures. Let's just wait until Moo2.0 and go from there +=begin for tears + # also while we are here and not in plain runmode: make sure we never + # loaded any of the strictures XS bullshit (it's a leak in a sense) + unless (DBICTest::RunMode->is_plain) { + for (qw(indirect multidimensional bareword::filehandles)) { + exists $INC{ Module::Runtime::module_notional_filename($_) } + and + $tb->ok(0, "$_ load apparently attempted!!!" ) + } + } +=cut + } }