X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil%2FLeakTracer.pm;h=49621ebc08c7c4b84fcb9311343cf23e4ad9fce7;hb=d8cf3aa31fb3d6ff7813f021fcc002663725fc41;hp=4873d77b3eb5de4f36c3f200a09cfb756d2f5af7;hpb=04c1a07034f365766217376a0ea194f14fb209a9;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 4873d77..49621eb 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -6,9 +6,9 @@ use strict;
 use ANFANG;
 use Carp;
 use Scalar::Util qw(isweak weaken blessed reftype);
-use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value);
+use DBIx::Class::_Util qw(refcount hrefaddr refdesc dump_value visit_namespaces);
 use DBICTest::RunMode;
-use DBICTest::Util qw( stacktrace visit_namespaces );
+use DBICTest::Util 'stacktrace';
 use constant {
   CV_TRACING => !!(
     !DBICTest::RunMode->is_plain
@@ -48,18 +48,23 @@ 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,
     };
 
-    # on perl < 5.8.3 sometimes a weaken can throw (can't find RT)
-    # so guard against that unlikely event
-    local $SIG{__DIE__} if $SIG{__DIE__};
-    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;
@@ -156,7 +161,16 @@ sub visit_refs {
         } values %{ scalar PadWalker::closed_over($r) } ] }); # scalar due to RT#92269
       }
       1;
-    } or warn "Could not descend into @{[ refdesc $r ]}: $@\n";
+    } or (
+      # this is some bizarre old DBI autosplit thing, no point mentioning it
+      $@ !~ m{ ^Can't \s locate \s (?:
+        auto/DBI/FIRSTKEY.al
+          |
+        \Qobject method "FIRSTKEY" via package "DBI"\E
+      )}x
+        and
+      warn "Could not descend into @{[ refdesc $r ]}: $@\n"
+    );
   }
   $visited_cnt;
 }
@@ -245,13 +259,13 @@ sub assert_empty_weakregistry {
 
   # 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
+  # that thorough - can get by with our own registry
   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 ],
+        refs => [ values %DBIx::Class::_Util::refs_closed_over_by_quote_sub_installed_crefs ],
         seen_refs => $refs,
         action => sub { 1 },
       );