X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FUtil.pm;h=3f489c21849ae380c074460436e11a15f077a010;hb=8d6b1478d;hp=b120acd87d5043a575c83d84782b04fb20e050e1;hpb=65d351219882184861384aedac6f251b6797d0d7;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm
index b120acd..3f489c2 100644
--- a/t/lib/DBICTest/Util.pm
+++ b/t/lib/DBICTest/Util.pm
@@ -5,9 +5,32 @@ use strict;
 
 use Carp;
 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
+use Config;
 
 use base 'Exporter';
-our @EXPORT_OK = qw/stacktrace populate_weakregistry assert_empty_weakregistry/;
+our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
+
+sub local_umask {
+  return unless defined $Config{d_umask};
+
+  die 'Calling local_umask() in void context makes no sense'
+    if ! defined wantarray;
+
+  my $old_umask = umask(shift());
+  die "Setting umask failed: $!" unless defined $old_umask;
+
+  return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
+}
+{
+  package DBICTest::Util::UmaskGuard;
+  sub DESTROY {
+    local ($@, $!);
+    eval { defined (umask ${$_[0]}) or die };
+    warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
+      if ($@ || $!);
+  }
+}
+
 
 sub stacktrace {
   my $frame = shift;
@@ -24,10 +47,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 +59,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 +113,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");
+    }
   }
 }