X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil%2FLeakTracer.pm;h=b1de109e6bebb5e85a89ef6d4533174ecca80393;hb=d52fc26dd05b56a41494a5ec86cddecfe3587b96;hp=1a56f415c21a8937331cfcbafb4955aa13ba7af2;hpb=8d73fcd44e0441f0252744be32bada6816c5ff6b;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 1a56f41..b1de109 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,
+  CV_TRACING => !DBICTest::RunMode->is_plain && DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
 };
 
 use base 'Exporter';
@@ -43,17 +42,17 @@ 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),
       weakref => $target,
     };
-    weaken( $weak_registry->{$refaddr}{weakref} );
-    $refs_traced++;
+
+    # 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};
   }
 
   my $desc = refdesc $target;
@@ -91,6 +90,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 {
@@ -141,7 +145,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";
@@ -149,38 +153,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 {
@@ -188,41 +166,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;
     }
   );
 
@@ -240,12 +209,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';
 
@@ -293,7 +260,7 @@ sub assert_empty_weakregistry {
     next if ! defined $weak_registry->{$addr}{weakref};
 
     $leaks_found++ unless $tb->in_todo;
-    $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
+    $tb->ok (0, "Expected garbage collection of $weak_registry->{$addr}{display_name}");
 
     my $diag = do {
       local $Data::Dumper::Maxdepth = 1;
@@ -331,20 +298,27 @@ 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] );
   }
 }
 
 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) {
 
@@ -358,6 +332,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!!!" )
+      }
+    }
   }
 }