Move classdata handling to DBICTest::Util::LeakTracer

diff --git a/t/52leaks.t b/t/52leaks.t
index 9f8c71a..4923be0 100644 (file)
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -50,7 +50,6 @@ use DBICTest::RunMode;
 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
 use Scalar::Util 'refaddr';
 use DBIx::Class;
-use B 'svref_2object';
 BEGIN {
   plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
     if DBIx::Class::_ENV_::PEEPEENESS;
@@ -117,7 +116,6 @@ unless (DBICTest::RunMode->is_plain) {
   %$weak_registry = ();
 }
 
-my @compose_ns_classes;
 {
   use_ok ('DBICTest');
 
@@ -125,8 +123,6 @@ my @compose_ns_classes;
   my $rs = $schema->resultset ('Artist');
   my $storage = $schema->storage;
 
-  @compose_ns_classes = map { "DBICTest::${_}" } keys %{$schema->source_registrations};
-
   ok ($storage->connected, 'we are connected');
 
   my $row_obj = $rs->search({}, { rows => 1})->next;  # so that commits/rollbacks work
@@ -385,34 +381,6 @@ for my $slot (keys %$weak_registry) {
   }
 }
 
-# every result class has a result source instance as classdata
-# make sure these are all present and distinct before ignoring
-# (distinct means only 1 reference)
-for my $rs_class (
-  'DBICTest::BaseResult',
-  @compose_ns_classes,
-  map { DBICTest::Schema->class ($_) } DBICTest::Schema->sources
-) {
-  # need to store the SVref and examine it separately, to push the rsrc instance off the pad
-  my $SV = svref_2object($rs_class->result_source_instance);
-  is( $SV->REFCNT, 1, "Source instance of $rs_class referenced exactly once" );
-
-  # ignore it
-  delete $weak_registry->{$rs_class->result_source_instance};
-}
-
-# Schema classes also hold sources, but these are clones, since
-# each source contains the schema (or schema class name in this case)
-# Hence the clone so that the same source can be registered with
-# multiple schemas
-for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) {
-
-  my $SV = svref_2object(DBICTest::Schema->source($moniker));
-  is( $SV->REFCNT, 1, "Source instance registered under DBICTest::Schema as $moniker referenced exactly once" );
-
-  delete $weak_registry->{DBICTest::Schema->source($moniker)};
-}
-
 # FIXME !!!
 # There is an actual strong circular reference taking place here, but because
 # half of it is in XS no leaktracer sees it, and Devel::FindRef is equally

diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index d0e63f2..2c10000 100644 (file)
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -5,6 +5,7 @@ use strict;
 
 use Carp;
 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use B 'svref_2object';
 use DBICTest::Util 'stacktrace';
 
 use base 'Exporter';
@@ -20,23 +21,28 @@ sub populate_weakregistry {
   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;
+
   $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
     (defined blessed $target) ? blessed($target) . '=' : '',
     reftype $target,
-    refaddr $target,
+    $refaddr,
   );
 
   if (defined $weak_registry->{$slot}{weakref}) {
-    if ( refaddr($weak_registry->{$slot}{weakref}) != (refaddr $target) ) {
-      print STDERR "Bail out! Weak Registry slot collision: $weak_registry->{$slot}{weakref} / $target\n";
+    if ( $weak_registry->{$slot}{refaddr} != $refaddr ) {
+      print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n";
       exit 255;
     }
   }
   else {
-    $refs_traced++;
+    $weak_registry->{$slot} = {
+      stacktrace => stacktrace(1),
+      refaddr => $refaddr,
+      renumber => $_[2] ? 0 : 1,
+    };
     weaken( $weak_registry->{$slot}{weakref} = $target );
-    $weak_registry->{$slot}{stacktrace} = stacktrace(1);
-    $weak_registry->{$slot}{renumber} = 1 unless $_[2];
+    $refs_traced++;
   }
 
   weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
@@ -63,7 +69,9 @@ sub CLONE {
       my $slot = shift @live_slots;
       my $inst = shift @live_instances;
 
-      $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', refaddr($inst))/ieg
+      my $refaddr = $inst->{refaddr} = refaddr($inst);
+
+      $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg
         if $inst->{renumber};
 
       $reg->{$slot} = $inst;
@@ -88,6 +96,60 @@ sub assert_empty_weakregistry {
   }
 
 
+  # compile a list of refs stored as CAG class data, so we can skip them
+  # intelligently below
+  my ($classdata_refcounts, $symwalker, $refwalker);
+
+  $refwalker = sub {
+    return unless length ref $_[0];
+
+    my $seen = $_[1] || {};
+    return if $seen->{refaddr $_[0]}++;
+
+    $classdata_refcounts->{refaddr $_[0]}++;
+
+    my $type = reftype $_[0];
+    if ($type eq 'HASH') {
+      $refwalker->($_, $seen) for values %{$_[0]};
+    }
+    elsif ($type eq 'ARRAY') {
+      $refwalker->($_, $seen) for @{$_[0]};
+    }
+    elsif ($type eq 'REF') {
+      $refwalker->($$_, $seen);
+    }
+  };
+
+  $symwalker = sub {
+    no strict 'refs';
+    my $pkg = shift || '::';
+
+    $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
+
+    $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
+  };
+
+  # run things twice, some cycles will be broken, introducing new
+  # candidates for pseudo-GC
+  for (1,2) {
+    undef $classdata_refcounts;
+
+    $symwalker->();
+
+    for my $slot (keys %$weak_registry) {
+      if (
+        defined $weak_registry->{$slot}{weakref}
+          and
+        my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}}
+      ) {
+        # need to store the SVref and examine it separately,
+        # to push the weakref instance off the pad
+        my $sv = svref_2object($weak_registry->{$slot}{weakref});
+        delete $weak_registry->{$slot} if $sv->REFCNT == $expected_refcnt;
+      }
+    }
+  }
+
   for my $slot (sort keys %$weak_registry) {
     ! defined $weak_registry->{$slot}{weakref} and next if $quiet;