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=ad61cd369df9727ebb693f984cdd6f4873149959;hpb=4841171c044c1da146dbfd7485b368b13f332b36;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm index ad61cd3..8002e69 100644 --- a/t/lib/DBICTest/Util/LeakTracer.pm +++ b/t/lib/DBICTest/Util/LeakTracer.pm @@ -3,15 +3,20 @@ package DBICTest::Util::LeakTracer; use warnings; use strict; +use ANFANG; use Carp; use Scalar::Util qw(isweak weaken blessed reftype); -use DBIx::Class::_Util qw(refcount hrefaddr refdesc); -use DBIx::Class::Optional::Dependencies; -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 => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), - SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0, + CV_TRACING => !!( + !DBICTest::RunMode->is_plain + && + require DBIx::Class::Optional::Dependencies + && + DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy') + ), }; use base 'Exporter'; @@ -43,21 +48,23 @@ 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'; + 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, }; - # on perl < 5.8.3 sometimes a weaken can throw (can't find RT) - # so guard against that unlikely event - local $@; - eval { weaken( $weak_registry->{$refaddr}{weakref} ); $refs_traced++ } - or delete $weak_registry->{$refaddr}; + weaken( $weak_registry->{$refaddr}{weakref} ); + + $refs_traced++; } my $desc = refdesc $target; @@ -71,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 = (); @@ -95,6 +102,11 @@ 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 { @@ -127,6 +139,7 @@ sub visit_refs { my $type = reftype $r; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { if ($type eq 'HASH') { @@ -145,7 +158,7 @@ sub visit_refs { 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 + } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269 } 1; } or warn "Could not descend into @{[ refdesc $r ]}: $@\n"; @@ -153,38 +166,12 @@ sub visit_refs { $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 { @@ -192,41 +179,32 @@ sub symtable_referenced_addresses { 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] } }, + 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") : () ), + # *{"${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"} : () + ( 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"}{$_} + ( defined *{"${pkg}::$sym"}{$_} and ! isweak(defined *{"${pkg}::$sym"}{$_}) ) + ? *{"${pkg}::$sym"}{$_} : () } qw(HASH ARRAY IO GLOB) ), - } keys %$pkg ], - ) unless $pkg =~ /^ :: (?: + } keys %{"${pkg}::"} ], + ) unless $pkg =~ /^ (?: DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3 - ) :: $/x; + ) $/x; } ); @@ -244,12 +222,10 @@ sub symtable_referenced_addresses { 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() ) }; + *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : CORE::caller() ) }; croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; @@ -308,7 +284,7 @@ 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} ; }; @@ -335,13 +311,13 @@ sub assert_empty_weakregistry { # Devel::MAT::Dumper::dumpfh( $fh ); # close ($fh) or die $!; # -# use POSIX; +# require POSIX; # POSIX::_exit(1); # } } if (! $quiet and !$leaks_found and ! $tb->in_todo) { - $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); + $tb->ok(1, sprintf "No leaks found at %s line %d", (CORE::caller())[1,2] ); } } @@ -370,20 +346,23 @@ END { $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) { + 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!!!" ) } } -=cut - } }