t/lib/DBICTest/Util/LeakTracer.pm

   1 package DBICTest::Util::LeakTracer;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Carp;
   7 use Scalar::Util qw/isweak weaken blessed reftype refaddr/;
   8 use B 'svref_2object';
   9 use DBICTest::Util 'stacktrace';
  10
  11 use base 'Exporter';
  12 our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/;
  13
  14 my $refs_traced = 0;
  15 my $leaks_found;
  16 my %reg_of_regs;
  17
  18 sub populate_weakregistry {
  19   my ($weak_registry, $target, $slot) = @_;
  20
  21   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
  22   croak 'Target is not a reference' unless length ref $target;
  23
  24   my $refaddr = refaddr $target;
  25
  26   $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification
  27     (defined blessed $target) ? blessed($target) . '=' : '',
  28     reftype $target,
  29     $refaddr,
  30   );
  31
  32   if (defined $weak_registry->{$slot}{weakref}) {
  33     if ( $weak_registry->{$slot}{refaddr} != $refaddr ) {
  34       print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n";
  35       exit 255;
  36     }
  37   }
  38   else {
  39     $weak_registry->{$slot} = {
  40       stacktrace => stacktrace(1),
  41       refaddr => $refaddr,
  42       renumber => $_[2] ? 0 : 1,
  43     };
  44     weaken( $weak_registry->{$slot}{weakref} = $target );
  45     $refs_traced++;
  46   }
  47
  48   weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry )
  49     unless( $reg_of_regs{ refaddr($weak_registry) } );
  50
  51   $target;
  52 }
  53
  54 # Renumber everything we auto-named on a thread spawn
  55 sub CLONE {
  56   my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
  57   %reg_of_regs = ();
  58
  59   for my $reg (@individual_regs) {
  60     my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg
  61       or next;
  62
  63     my @live_instances = @{$reg}{@live_slots};
  64
  65     $reg = {};  # get a fresh hashref in the new thread ctx
  66     weaken( $reg_of_regs{refaddr($reg)} = $reg );
  67
  68     while (@live_slots) {
  69       my $slot = shift @live_slots;
  70       my $inst = shift @live_instances;
  71
  72       my $refaddr = $inst->{refaddr} = refaddr($inst);
  73
  74       $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg
  75         if $inst->{renumber};
  76
  77       $reg->{$slot} = $inst;
  78     }
  79   }
  80 }
  81
  82 sub assert_empty_weakregistry {
  83   my ($weak_registry, $quiet) = @_;
  84
  85   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
  86
  87   return unless keys %$weak_registry;
  88
  89   my $tb = eval { Test::Builder->new }
  90     or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
  91
  92   for my $slot (sort keys %$weak_registry) {
  93     next if ! defined $weak_registry->{$slot}{weakref};
  94     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!")
  95       unless isweak( $weak_registry->{$slot}{weakref} );
  96   }
  97
  98
  99   # compile a list of refs stored as CAG class data, so we can skip them
 100   # intelligently below
 101   my ($classdata_refcounts, $symwalker, $refwalker);
 102
 103   $refwalker = sub {
 104     return unless length ref $_[0];
 105
 106     my $seen = $_[1] || {};
 107     return if $seen->{refaddr $_[0]}++;
 108
 109     $classdata_refcounts->{refaddr $_[0]}++;
 110
 111     my $type = reftype $_[0];
 112     if ($type eq 'HASH') {
 113       $refwalker->($_, $seen) for values %{$_[0]};
 114     }
 115     elsif ($type eq 'ARRAY') {
 116       $refwalker->($_, $seen) for @{$_[0]};
 117     }
 118     elsif ($type eq 'REF') {
 119       $refwalker->($$_, $seen);
 120     }
 121   };
 122
 123   $symwalker = sub {
 124     no strict 'refs';
 125     my $pkg = shift || '::';
 126
 127     $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
 128
 129     $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
 130   };
 131
 132   # run things twice, some cycles will be broken, introducing new
 133   # candidates for pseudo-GC
 134   for (1,2) {
 135     undef $classdata_refcounts;
 136
 137     $symwalker->();
 138
 139     for my $slot (keys %$weak_registry) {
 140       if (
 141         defined $weak_registry->{$slot}{weakref}
 142           and
 143         my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}}
 144       ) {
 145         # need to store the SVref and examine it separately,
 146         # to push the weakref instance off the pad
 147         my $sv = svref_2object($weak_registry->{$slot}{weakref});
 148         delete $weak_registry->{$slot} if $sv->REFCNT == $expected_refcnt;
 149       }
 150     }
 151   }
 152
 153   for my $slot (sort keys %$weak_registry) {
 154     ! defined $weak_registry->{$slot}{weakref} and next if $quiet;
 155
 156     $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do {
 157       $leaks_found = 1;
 158
 159       my $diag = '';
 160
 161       $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n"
 162         if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 163
 164       if (my $stack = $weak_registry->{$slot}{stacktrace}) {
 165         $diag .= "    Reference first seen$stack";
 166       }
 167
 168       $tb->diag($diag) if $diag;
 169     };
 170   }
 171 }
 172
 173 END {
 174   if ($INC{'Test/Builder.pm'}) {
 175     my $tb = Test::Builder->new;
 176
 177     # we check for test passage - a leak may be a part of a TODO
 178     if ($leaks_found and !$tb->is_passing) {
 179
 180       $tb->diag(sprintf
 181         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 182       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 183       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 184       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 185
 186     }
 187     else {
 188       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 189     }
 190   }
 191 }
 192
 193 1;