From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 15 Jan 2014 15:04:30 +0000 (+0100)
Subject: Now that we have the tools leak-track much more stuff when XS is there
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=21aa86aae083ccb5b94ba994dec030627e95e40b;p=dbsrgits%2FDBIx-Class-Historic.git

Now that we have the tools leak-track much more stuff when XS is there
---

diff --git a/t/52leaks.t b/t/52leaks.t
index bb375a3..4d029f0 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -47,7 +47,7 @@ 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 DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
 use DBIx::Class;
 BEGIN {
   plan skip_all => "Your perl version $] appears to leak like a sieve - skipping test"
@@ -275,6 +275,24 @@ unless (DBICTest::RunMode->is_plain) {
     pager => $pager,
   );
 
+  # FIXME - ideally this kind of collector ought to be global, but attempts
+  # with an invasive debugger-based tracer did not quite work out... yet
+  # Manually scan the innards of everything we have in the base collection
+  # we assembled so far (skip the DT madness below) *recursively*
+  #
+  # Only do this when we do have the bits to look inside CVs properly,
+  # without it we are liable to pick up object defaults that are locked
+  # in method closures
+  if (DBICTest::Util::LeakTracer::CV_TRACING) {
+    visit_refs(
+      refs => [ $base_collection ],
+      action => sub {
+        populate_weakregistry ($weak_registry, $_[0]);
+        1;  # true means "keep descending"
+      },
+    );
+  }
+
   if ($has_dt) {
     my $rs = $base_collection->{icdt_rs} = $schema->resultset('Event');
 
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index f3cf859..600a667 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -14,7 +14,7 @@ use constant {
 };
 
 use base 'Exporter';
-our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
+our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr visit_refs);
 
 my $refs_traced = 0;
 my $leaks_found = 0;