X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F52leaks.t;h=4d029f092625c71b98d23df5fcbf40684a78c820;hb=21aa86aae083ccb5b94ba994dec030627e95e40b;hp=9f8c71a8c2f2464c180d8a07a7b67480d64576b6;hpb=53a5200d634aaff6ed5663158f9df69c4f622205;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/52leaks.t b/t/52leaks.t
index 9f8c71a..4d029f0 100644
--- a/t/52leaks.t
+++ b/t/52leaks.t
@@ -47,10 +47,8 @@ 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 DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry visit_refs);
 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 +115,6 @@ unless (DBICTest::RunMode->is_plain) {
   %$weak_registry = ();
 }
 
-my @compose_ns_classes;
 {
   use_ok ('DBICTest');
 
@@ -125,8 +122,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
@@ -280,6 +275,24 @@ my @compose_ns_classes;
     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');
 
@@ -300,23 +313,6 @@ my @compose_ns_classes;
     $base_collection->{"DBI handle $_"} = $_;
   }
 
-  SKIP: {
-    if ( DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks') ) {
-      my @w;
-      local $SIG{__WARN__} = sub { $_[0] =~ /\QUnhandled type: REGEXP/ ? push @w, @_ : warn @_ };
-
-      Test::Memory::Cycle::memory_cycle_ok ($base_collection, 'No cycles in the object collection');
-
-      if ( $] > 5.011 ) {
-        local $TODO = 'Silence warning due to RT56681';
-        is (@w, 0, 'No Devel::Cycle emitted warnings');
-      }
-    }
-    else {
-      skip 'Circular ref test needs ' .  DBIx::Class::Optional::Dependencies->req_missing_for ('test_leaks'), 1;
-    }
-  }
-
   populate_weakregistry ($weak_registry, $base_collection->{$_}, "basic $_")
     for keys %$base_collection;
 }
@@ -359,58 +355,18 @@ my @compose_ns_classes;
 
 # 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};
-  }
-  elsif ($slot =~ /^Method::Generate::(?:Accessor|Constructor)/) {
-    # Moo keeps globals around, this is normal
-    delete $weak_registry->{$slot};
-  }
-  elsif ($slot =~ /^SQL::Translator::Generator::DDL::SQLite/) {
-    # 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};
   }
-  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/) {
-    # DT is going through a refactor it seems - let it leak zones for now
-    delete $weak_registry->{$slot};
-  }
-}
-
-# 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 !!!
@@ -424,7 +380,7 @@ for my $moniker ( keys %{DBICTest::Schema->source_registrations || {}} ) {
 #
 {
   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);
   }