X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil%2FLeakTracer.pm;h=8002e69890de54f3b00d17f9b62fe8c495226ada;hb=7bba735de0eb5d431bb3b36e6aec4b19370f9158;hp=794e83f5427ab75193a8a0753dc324b9e6ae329a;hpb=1a44a267c141d38f2fe083db2a0354f912df3489;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index 794e83f..8002e69 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -3,30 +3,29 @@ package DBICTest::Util::LeakTracer; use warnings; use strict; +use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util 'refcount'; -use Data::Dumper::Concise; +use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value visit_namespaces); +use DBICTest::RunMode; use DBICTest::Util 'stacktrace'; +use constant { + CV_TRACING => !!( + !DBICTest::RunMode->is_plain + && + require DBIx::Class::Optional::Dependencies + && + DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy') + ), +}; 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,16 +48,26 @@ sub populate_weakregistry { for keys %$reg; } + return $target if ( + DBIx::Class::_ENV_::BROKEN_WEAK_SCALARREF_VALUES + and + ref $target eq 'SCALAR' + ); + if (! defined $weak_registry->{$refaddr}{weakref}) { + + # replace slot entirely $weak_registry->{$refaddr} = { stacktrace => stacktrace(1), weakref => $target, }; + weaken( $weak_registry->{$refaddr}{weakref} ); + $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; @@ -69,7 +78,7 @@ sub populate_weakregistry { } # Regenerate the slots names on a thread spawn -sub CLONE { +sub DBICTest::__LeakTracer_iThreads_handler__::CLONE { my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; %reg_of_regs = (); @@ -93,17 +102,140 @@ sub CLONE { $reg->{$new_addr} = $slot_info; } } + + # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage + # collected before leaving this scope. Depending on the code above, this + # may very well be just a preventive measure guarding future modifications + undef; +} + +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 $SIG{__DIE__} if $SIG{__DIE__}; + 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($_) ) ? $_ : () + } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269 + } + 1; + } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; + } + $visited_cnt; +} + +# compiles a list of addresses stored as globals (possibly even catching +# class data in the form of method closures), so we can skip them further on +sub symtable_referenced_addresses { + + my $refs_per_pkg; + + my $seen_refs = {}; + visit_namespaces( + action => sub { + + no strict 'refs'; + + my $pkg = shift; + + # 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, + + action => sub { 1 }, + + 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) = @_; + # 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] : CORE::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,64 +248,32 @@ 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 { $_ =~ /(?(); - - 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; - } + # 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; } - } + : ( + # 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) { next if ! defined $weak_registry->{$addr}{weakref}; - $leaks_found++; - $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}"); + $leaks_found++ unless $tb->in_todo; + $tb->ok (0, "Expected garbage collection of $weak_registry->{$addr}{display_name}"); my $diag = do { local $Data::Dumper::Maxdepth = 1; @@ -184,11 +284,14 @@ sub assert_empty_weakregistry { ref($weak_registry->{$addr}{weakref}) eq 'CODE' and B::svref_2object($weak_registry->{$addr}{weakref})->XSUB - ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) + ) ? '__XSUB__' : dump_value $weak_registry->{$addr}{weakref} ; }; - $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n" + # 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) + + $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); $diag =~ s/^/ /mg; @@ -198,17 +301,37 @@ sub assert_empty_weakregistry { } $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 $!; +# +# require POSIX; +# POSIX::_exit(1); +# } } - if (! $quiet and ! $leaks_found) { - $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); + if (! $quiet and !$leaks_found and ! $tb->in_todo) { + $tb->ok(1, sprintf "No leaks found at %s line %d", (CORE::caller())[1,2] ); } } END { - if ($INC{'Test/Builder.pm'}) { - my $tb = Test::Builder->new; - + if ( + $INC{'Test/Builder.pm'} + and + my $tb = do { + local $@; + my $t = eval { Test::Builder->new } + or warn "Test::Builder->new failed:\n$@\n"; + $t; + } + ) { # we check for test passage - a leak may be a part of a TODO if ($leaks_found and !$tb->is_passing) { @@ -222,6 +345,24 @@ END { else { $tb->note("Auto checked $refs_traced references for leaks - none detected"); } + + # 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 ( + $ENV{MOO_FATAL_WARNINGS} + or + # FIXME - SQLT loads strictures explicitly, /facedesk + # remove this INC check when 0fb58589 and 45287c815 are rectified + $INC{'SQL/Translator.pm'} + or + DBICTest::RunMode->is_plain + ) { + for (qw(indirect multidimensional bareword::filehandles)) { + exists $INC{ Module::Runtime::module_notional_filename($_) } + and + $tb->ok(0, "$_ load should not have been attempted!!!" ) + } + } } }