From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 26 Mar 2012 03:11:24 +0000 (+0200)
Subject: Add all database connections via DBICTest::Schema to the leaktrace pool
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6918c70e3970b631dd6f4e298a87ae02476fbde1;p=dbsrgits%2FDBIx-Class-Historic.git

Add all database connections via DBICTest::Schema to the leaktrace pool
---

diff --git a/t/73oracle.t b/t/73oracle.t
index 1866a3d..01331b1 100644
--- a/t/73oracle.t
+++ b/t/73oracle.t
@@ -679,6 +679,7 @@ END {
     next unless $_;
     local $SIG{__WARN__} = sub {};
     do_clean($_);
-    $_->disconnect;
   }
+  undef $dbh;
+  undef $dbh2;
 }
diff --git a/t/73oracle_blob.t b/t/73oracle_blob.t
index c94cec3..3965ea3 100644
--- a/t/73oracle_blob.t
+++ b/t/73oracle_blob.t
@@ -186,10 +186,9 @@ sub do_clean {
 }
 
 END {
-  for ($dbh) {
-    next unless $_;
+  if ($dbh) {
     local $SIG{__WARN__} = sub {};
-    do_clean($_);
-    $_->disconnect;
+    do_clean($dbh);
+    undef $dbh;
   }
 }
diff --git a/t/inflate/datetime_oracle.t b/t/inflate/datetime_oracle.t
index 72e0e17..2a9b0c3 100644
--- a/t/inflate/datetime_oracle.t
+++ b/t/inflate/datetime_oracle.t
@@ -109,7 +109,7 @@ done_testing;
 
 # clean up our mess
 END {
-  if($schema && ($dbh = $schema->storage->dbh)) {
+  if($schema && (my $dbh = $schema->storage->dbh)) {
     $dbh->do("DROP TABLE track");
   }
   undef $schema;
diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm
index 285582d..5d2518a 100644
--- a/t/lib/DBICTest/Schema.pm
+++ b/t/lib/DBICTest/Schema.pm
@@ -76,8 +76,23 @@ sub clone {
 
 sub connection {
   my $self = shift->next::method(@_);
-  populate_weakregistry ( $weak_registry, $self->storage )
-    if $INC{'Test/Builder.pm'};
+
+  if ($INC{'Test/Builder.pm'}) {
+    populate_weakregistry ( $weak_registry, $self->storage );
+
+    my $cur_connect_call = $self->storage->on_connect_call;
+
+    $self->storage->on_connect_call([
+      (ref $cur_connect_call eq 'ARRAY'
+        ? @$cur_connect_call
+        : ($cur_connect_call || ())
+      ),
+      [sub {
+        populate_weakregistry( $weak_registry, shift->_dbh )
+      }],
+    ]);
+  }
+
   $self;
 }
 
diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index b120acd..9f5e985 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -24,10 +24,10 @@ sub stacktrace {
   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
 }
 
+my $refs_traced = 0;
 sub populate_weakregistry {
   my ($reg, $target, $slot) = @_;
 
-
   croak 'Target is not a reference' unless defined ref $target;
 
   $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
@@ -36,8 +36,17 @@ sub populate_weakregistry {
     refaddr $target,
   );
 
-  weaken( $reg->{$slot}{weakref} = $target );
-  $reg->{$slot}{stacktrace} = stacktrace(1);
+  if (defined $reg->{$slot}{weakref}) {
+    if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) {
+      print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n";
+      exit 255;
+    }
+  }
+  else {
+    $refs_traced++;
+    weaken( $reg->{$slot}{weakref} = $target );
+    $reg->{$slot}{stacktrace} = stacktrace(1);
+  }
 
   $target;
 }
@@ -81,13 +90,22 @@ sub assert_empty_weakregistry {
 }
 
 END {
-  if ($leaks_found) {
+  if ($INC{'Test/Builder.pm'}) {
     my $tb = Test::Builder->new;
-    $tb->diag(sprintf
-      "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
-    . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
-    . "\n\n%s\n%s\n\n", ('#' x 16) x 4
-    ) if (!$tb->is_passing and (!$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'}));
+
+    # we check for test passage - a leak may be a part of a TODO
+    if ($leaks_found and !$tb->is_passing) {
+
+      $tb->diag(sprintf
+        "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
+      . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
+      . "\n\n%s\n%s\n\n", ('#' x 16) x 4
+      ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
+
+    }
+    else {
+      $tb->note("Auto checked $refs_traced references for leaks - none detected");
+    }
   }
 }