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