X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil%2FLeakTracer.pm;h=3da3b86e15f87bb35f1297cb6ba7fa9b64a82b0b;hb=90a8030442ff2b9b6414ec9d8d7119b28d36426c;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..3da3b86 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -8,10 +8,9 @@ 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 DBICTest::Util 'stacktrace';
+use DBICTest::Util qw( stacktrace visit_namespaces );
 use constant {
   CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
-  SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0,
 };
 
 use base 'Exporter';
@@ -43,10 +42,6 @@ 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),
@@ -145,7 +140,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 +148,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
-        { $_ =~ /(?<!^main)::$/ }
-        do {  no strict 'refs'; keys %{ $base . '::'} }
-  }
-
-  return $visited;
-}
-
 # 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 $dummy_addresslist;
-
   my $seen_refs = {};
   visit_namespaces(
     action => sub {
@@ -192,41 +161,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,8 +204,6 @@ 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;
@@ -370,20 +328,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
-
   }
 }