t/lib/DBICTest/Util.pm

   1 package DBICTest::Util;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Carp;
   7 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
   8 use Config;
   9
  10 use base 'Exporter';
  11 our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/;
  12
  13 sub local_umask {
  14   return unless defined $Config{d_umask};
  15
  16   die 'Calling local_umask() in void context makes no sense'
  17     if ! defined wantarray;
  18
  19   my $old_umask = umask(shift());
  20   die "Setting umask failed: $!" unless defined $old_umask;
  21
  22   return bless \$old_umask, 'DBICTest::Util::UmaskGuard';
  23 }
  24 {
  25   package DBICTest::Util::UmaskGuard;
  26   sub DESTROY {
  27     local ($@, $!);
  28     eval { defined (umask ${$_[0]}) or die };
  29     warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') )
  30       if ($@ || $!);
  31   }
  32 }
  33
  34
  35 sub stacktrace {
  36   my $frame = shift;
  37   $frame++;
  38   my (@stack, @frame);
  39
  40   while (@frame = caller($frame++)) {
  41     push @stack, [@frame[3,1,2]];
  42   }
  43
  44   return undef unless @stack;
  45
  46   $stack[0][0] = '';
  47   return join "\tinvoked as ", map { sprintf ("%s at %s line %d\n", @$_ ) } @stack;
  48 }
  49
  50 my $refs_traced = 0;
  51 sub populate_weakregistry {
  52   my ($reg, $target, $slot) = @_;
  53
  54   croak 'Target is not a reference' unless defined ref $target;
  55
  56   $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
  57     (defined blessed $target) ? blessed($target) . '=' : '',
  58     reftype $target,
  59     refaddr $target,
  60   );
  61
  62   if (defined $reg->{$slot}{weakref}) {
  63     if ( refaddr($reg->{$slot}{weakref}) != (refaddr $target) ) {
  64       print STDERR "Bail out! Weak Registry slot collision: $reg->{$slot}{weakref} / $target\n";
  65       exit 255;
  66     }
  67   }
  68   else {
  69     $refs_traced++;
  70     weaken( $reg->{$slot}{weakref} = $target );
  71     $reg->{$slot}{stacktrace} = stacktrace(1);
  72   }
  73
  74   $target;
  75 }
  76
  77 my $leaks_found;
  78 sub assert_empty_weakregistry {
  79   my ($weak_registry, $quiet) = @_;
  80
  81   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
  82
  83   return unless keys %$weak_registry;
  84
  85   my $tb = eval { Test::Builder->new }
  86     or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
  87
  88   for my $slot (sort keys %$weak_registry) {
  89     next if ! defined $weak_registry->{$slot}{weakref};
  90     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
  91       unless isweak( $weak_registry->{$slot}{weakref} );
  92   }
  93
  94
  95   for my $slot (sort keys %$weak_registry) {
  96     ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
  97
  98     $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
  99       $leaks_found = 1;
 100
 101       my $diag = '';
 102
 103       $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
 104         if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 105
 106       if (my $stack = $weak_registry->{$slot}{stacktrace}) {
 107         $diag .= "    Reference first seen$stack";
 108       }
 109
 110       $tb->diag($diag) if $diag;
 111     };
 112   }
 113 }
 114
 115 END {
 116   if ($INC{'Test/Builder.pm'}) {
 117     my $tb = Test::Builder->new;
 118
 119     # we check for test passage - a leak may be a part of a TODO
 120     if ($leaks_found and !$tb->is_passing) {
 121
 122       $tb->diag(sprintf
 123         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 124       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 125       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 126       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 127
 128     }
 129     else {
 130       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 131     }
 132   }
 133 }
 134
 135 1;