From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sun, 29 Dec 2013 06:25:53 +0000 (+0100)
Subject: Rewire the leaktracer to store all refs by address, not by name
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=965776574a5447eb2449f29ba1d13e03cbc49be6;p=dbsrgits%2FDBIx-Class-Historic.git

Rewire the leaktracer to store all refs by address, not by name

Also add better diagnostics during failure
---

diff --git a/t/52leaks.t b/t/52leaks.t
index 4923be0..07f57b7 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -48,7 +48,6 @@ if ($ENV{DBICTEST_IN_PERSISTENT_ENV}) {
 use lib qw(t/lib);
 use DBICTest::RunMode;
 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
-use Scalar::Util 'refaddr';
 use DBIx::Class;
 BEGIN {
   plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
@@ -355,29 +354,31 @@ unless (DBICTest::RunMode->is_plain) {
 
 # Naturally we have some exceptions
 my $cleared;
-for my $slot (keys %$weak_registry) {
-  if ($slot =~ /^Test::Builder/) {
+for my $addr (keys %$weak_registry) {
+  my $names = join "\n", keys %{$weak_registry->{$addr}{slot_names}};
+
+  if ($names =~ /^Test::Builder/m) {
     # T::B 2.0 has result objects and other fancyness
-    delete $weak_registry->{$slot};
+    delete $weak_registry->{$addr};
   }
-  elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) {
+  elsif ($names =~ /^Method::Generate::(?:Accessor|Constructor)/m) {
     # Moo keeps globals around, this is normal
-    delete $weak_registry->{$slot};
+    delete $weak_registry->{$addr};
   }
-  elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) {
+  elsif ($names =~ /^SQL::Translator::Generator::DDL::SQLite/m) {
     # SQLT::Producer::SQLite keeps global generators around for quoted
     # and non-quoted DDL, allow one for each quoting style
-    delete $weak_registry->{$slot}
-      unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$slot}{weakref}->quote_chars}}++;
+    delete $weak_registry->{$addr}
+      unless $cleared->{sqlt_ddl_sqlite}->{@{$weak_registry->{$addr}{weakref}->quote_chars}}++;
   }
-  elsif ($slot =~ /^Hash::Merge/) {
+  elsif ($names =~ /^Hash::Merge/m) {
     # only clear one object of a specific behavior - more would indicate trouble
-    delete $weak_registry->{$slot}
-      unless $cleared->{hash_merge_singleton}{$weak_registry->{$slot}{weakref}{behavior}}++;
+    delete $weak_registry->{$addr}
+      unless $cleared->{hash_merge_singleton}{$weak_registry->{$addr}{weakref}{behavior}}++;
   }
-  elsif ($slot =~ /^DateTime::TimeZone/) {
+  elsif ($names =~ /^DateTime::TimeZone/m) {
     # DT is going through a refactor it seems - let it leak zones for now
-    delete $weak_registry->{$slot};
+    delete $weak_registry->{$addr};
   }
 }
 
@@ -392,7 +393,7 @@ for my $slot (keys %$weak_registry) {
 #
 {
   local $TODO = 'This fails intermittently - see RT#82942';
-  if ( my $r = $weak_registry->{'basic leaky_resultset_cond'}{weakref} ) {
+  if ( my $r = ($weak_registry->{'basic leaky_resultset_cond'}||{})->{weakref} ) {
     ok(! defined $r, 'Self-referential RS conditions no longer leak!')
       or $r->result_source(undef);
   }
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 8320efe..5c91afe 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -4,77 +4,85 @@ use warnings;
 use strict;
 
 use Carp;
-use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use Scalar::Util qw(isweak weaken blessed reftype);
 use DBIx::Class::_Util 'refcount';
+use Data::Dumper::Concise;
 use DBICTest::Util 'stacktrace';
 
 use base 'Exporter';
-our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
+our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
 
 my $refs_traced = 0;
-my $leaks_found;
+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, $slot) = @_;
+  my ($weak_registry, $target, $note) = @_;
 
   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
   croak 'Target is not a reference' unless length ref $target;
 
-  my $refaddr = refaddr $target;
+  my $refaddr = hrefaddr $target;
 
-  $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
-    (defined blessed $target) ? blessed($target) . '=' : '',
-    reftype $target,
-    $refaddr,
-  );
+  # a registry could be fed to itself or another registry via recursive sweeps
+  return $target if $reg_of_regs{$refaddr};
 
-  if (defined $weak_registry->{$slot}{weakref}) {
-    if ( $weak_registry->{$slot}{refaddr} != $refaddr ) {
-      print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n";
-      exit 255;
-    }
-  }
-  else {
-    $weak_registry->{$slot} = {
+  if (! defined $weak_registry->{$refaddr}{weakref}) {
+    $weak_registry->{$refaddr} = {
       stacktrace => stacktrace(1),
-      refaddr => $refaddr,
-      renumber => $_[2] ? 0 : 1,
+      weakref => $target,
     };
-    weaken( $weak_registry->{$slot}{weakref} = $target );
+    weaken( $weak_registry->{$refaddr}{weakref} );
     $refs_traced++;
   }
 
-  weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
-    unless( $reg_of_regs{ refaddr($weak_registry) } );
+  my $desc = _describe_ref($target);
+  $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
+  if ($note) {
+    $note =~ s/\s*\Q$desc\E\s*//g;
+    $weak_registry->{$refaddr}{slot_names}{$note} = 1;
+  }
+
+  weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
+    unless( $reg_of_regs{ hrefaddr($weak_registry) } );
 
   $target;
 }
 
-# Renumber everything we auto-named on a thread spawn
+# Regenerate the slots names on a thread spawn
 sub CLONE {
   my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
   %reg_of_regs = ();
 
   for my $reg (@individual_regs) {
-    my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
+    my @live_slots = grep { defined $_->{weakref} } values %$reg
       or next;
 
-    my @live_instances = @{$reg}{@live_slots};
-
     $reg = {};  # get a fresh hashref in the new thread ctx
-    weaken( $reg_of_regs{refaddr($reg)} = $reg );
-
-    while (@live_slots) {
-      my $slot = shift @live_slots;
-      my $inst = shift @live_instances;
+    weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
 
-      my $refaddr = $inst->{refaddr} = refaddr($inst);
+    for my $slot_info (@live_slots) {
+      my $new_addr = hrefaddr $slot_info->{weakref};
 
-      $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg
-        if $inst->{renumber};
+      # replace all slot names
+      $slot_info->{slot_names} = { map {
+        my $name = $_;
+        $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
+        ($name => 1);
+      } keys %{$slot_info->{slot_names}} };
 
-      $reg->{$slot} = $inst;
+      $reg->{$new_addr} = $slot_info;
     }
   }
 }
@@ -89,12 +97,16 @@ sub assert_empty_weakregistry {
   my $tb = eval { Test::Builder->new }
     or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
 
-  for my $slot (sort keys %$weak_registry) {
-    next if ! defined $weak_registry->{$slot}{weakref};
-    $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
-      unless isweak( $weak_registry->{$slot}{weakref} );
-  }
+  for my $addr (keys %$weak_registry) {
+    $weak_registry->{$addr}{display_name} = join ' | ', (
+      sort
+        { length $a <=> length $b or $a cmp $b }
+        keys %{$weak_registry->{$addr}{slot_names}}
+    );
 
+    $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
+      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
@@ -104,9 +116,9 @@ sub assert_empty_weakregistry {
     return unless length ref $_[0];
 
     my $seen = $_[1] || {};
-    return if $seen->{refaddr $_[0]}++;
+    return if $seen->{hrefaddr $_[0]}++;
 
-    $classdata_refcounts->{refaddr $_[0]}++;
+    $classdata_refcounts->{hrefaddr $_[0]}++;
 
     my $type = reftype $_[0];
     if ($type eq 'HASH') {
@@ -136,34 +148,48 @@ sub assert_empty_weakregistry {
 
     $symwalker->();
 
-    for my $slot (keys %$weak_registry) {
+    for my $refaddr (keys %$weak_registry) {
       if (
-        defined $weak_registry->{$slot}{weakref}
+        defined $weak_registry->{$refaddr}{weakref}
           and
-        my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}}
+        my $expected_refcnt = $classdata_refcounts->{$refaddr}
       ) {
-        delete $weak_registry->{$slot}
-          if refcount($weak_registry->{$slot}{weakref}) == $expected_refcnt;
+        delete $weak_registry->{$refaddr}
+          if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
       }
     }
   }
 
-  for my $slot (sort keys %$weak_registry) {
-    ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
+  for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
+
+    ! defined $weak_registry->{$addr}{weakref} and next if $quiet;
 
-    $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
-      $leaks_found = 1;
+    $tb->ok (! defined $weak_registry->{$addr}{weakref}, "No leaks of $weak_registry->{$addr}{display_name}") or do {
+      $leaks_found++;
 
-      my $diag = '';
+      my $diag = do {
+        local $Data::Dumper::Maxdepth = 1;
+        sprintf "\n%s (refcnt %d) => %s\n",
+          $weak_registry->{$addr}{display_name},
+          refcount($weak_registry->{$addr}{weakref}),
+          (
+            ref($weak_registry->{$addr}{weakref}) eq 'CODE'
+              and
+            B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
+          ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
+        ;
+      };
 
-      $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
+      $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n"
         if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 
-      if (my $stack = $weak_registry->{$slot}{stacktrace}) {
+      $diag =~ s/^/    /mg;
+
+      if (my $stack = $weak_registry->{$addr}{stacktrace}) {
         $diag .= "    Reference first seen$stack";
       }
 
-      $tb->diag($diag) if $diag;
+      $tb->diag($diag);
     };
   }
 }