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);
   8 use DBIx::Class::_Util 'refcount';
   9 use Data::Dumper::Concise;
  10 use DBICTest::Util 'stacktrace';
  11
  12 use base 'Exporter';
  13 our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr);
  14
  15 my $refs_traced = 0;
  16 my $leaks_found = 0;
  17 my %reg_of_regs;
  18
  19 sub hrefaddr { sprintf '0x%x', &Scalar::Util::refaddr }
  20
  21 # so we don't trigger stringification
  22 sub _describe_ref {
  23   sprintf '%s%s(%s)',
  24     (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
  25     reftype $_[0],
  26     hrefaddr $_[0],
  27   ;
  28 }
  29
  30 sub populate_weakregistry {
  31   my ($weak_registry, $target, $note) = @_;
  32
  33   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
  34   croak 'Target is not a reference' unless length ref $target;
  35
  36   my $refaddr = hrefaddr $target;
  37
  38   # a registry could be fed to itself or another registry via recursive sweeps
  39   return $target if $reg_of_regs{$refaddr};
  40
  41   weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
  42     unless( $reg_of_regs{ hrefaddr($weak_registry) } );
  43
  44   # an explicit "garbage collection" pass every time we store a ref
  45   # if we do not do this the registry will keep growing appearing
  46   # as if the traced program is continuously slowly leaking memory
  47   for my $reg (values %reg_of_regs) {
  48     (defined $reg->{$_}{weakref}) or delete $reg->{$_}
  49       for keys %$reg;
  50   }
  51
  52   if (! defined $weak_registry->{$refaddr}{weakref}) {
  53     $weak_registry->{$refaddr} = {
  54       stacktrace => stacktrace(1),
  55       weakref => $target,
  56     };
  57     weaken( $weak_registry->{$refaddr}{weakref} );
  58     $refs_traced++;
  59   }
  60
  61   my $desc = _describe_ref($target);
  62   $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
  63   if ($note) {
  64     $note =~ s/\s*\Q$desc\E\s*//g;
  65     $weak_registry->{$refaddr}{slot_names}{$note} = 1;
  66   }
  67
  68   $target;
  69 }
  70
  71 # Regenerate the slots names on a thread spawn
  72 sub CLONE {
  73   my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
  74   %reg_of_regs = ();
  75
  76   for my $reg (@individual_regs) {
  77     my @live_slots = grep { defined $_->{weakref} } values %$reg
  78       or next;
  79
  80     $reg = {};  # get a fresh hashref in the new thread ctx
  81     weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
  82
  83     for my $slot_info (@live_slots) {
  84       my $new_addr = hrefaddr $slot_info->{weakref};
  85
  86       # replace all slot names
  87       $slot_info->{slot_names} = { map {
  88         my $name = $_;
  89         $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
  90         ($name => 1);
  91       } keys %{$slot_info->{slot_names}} };
  92
  93       $reg->{$new_addr} = $slot_info;
  94     }
  95   }
  96 }
  97
  98 sub assert_empty_weakregistry {
  99   my ($weak_registry, $quiet) = @_;
 100
 101   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
 102
 103   return unless keys %$weak_registry;
 104
 105   my $tb = eval { Test::Builder->new }
 106     or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense';
 107
 108   for my $addr (keys %$weak_registry) {
 109     $weak_registry->{$addr}{display_name} = join ' | ', (
 110       sort
 111         { length $a <=> length $b or $a cmp $b }
 112         keys %{$weak_registry->{$addr}{slot_names}}
 113     );
 114
 115     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
 116       if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
 117   }
 118
 119   # compile a list of refs stored as CAG class data, so we can skip them
 120   # intelligently below
 121   my ($classdata_refcounts, $symwalker, $refwalker);
 122
 123   $refwalker = sub {
 124     return unless length ref $_[0];
 125
 126     my $seen = $_[1] || {};
 127     return if $seen->{hrefaddr $_[0]}++;
 128
 129     $classdata_refcounts->{hrefaddr $_[0]}++;
 130
 131     my $type = reftype $_[0];
 132     if ($type eq 'HASH') {
 133       $refwalker->($_, $seen) for values %{$_[0]};
 134     }
 135     elsif ($type eq 'ARRAY') {
 136       $refwalker->($_, $seen) for @{$_[0]};
 137     }
 138     elsif ($type eq 'REF') {
 139       $refwalker->($$_, $seen);
 140     }
 141   };
 142
 143   $symwalker = sub {
 144     no strict 'refs';
 145     my $pkg = shift || '::';
 146
 147     $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg;
 148
 149     $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
 150   };
 151
 152   # run things twice, some cycles will be broken, introducing new
 153   # candidates for pseudo-GC
 154   for (1,2) {
 155     undef $classdata_refcounts;
 156
 157     $symwalker->();
 158
 159     for my $refaddr (keys %$weak_registry) {
 160       if (
 161         defined $weak_registry->{$refaddr}{weakref}
 162           and
 163         my $expected_refcnt = $classdata_refcounts->{$refaddr}
 164       ) {
 165         delete $weak_registry->{$refaddr}
 166           if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt;
 167       }
 168     }
 169   }
 170
 171   for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
 172
 173     next if ! defined $weak_registry->{$addr}{weakref};
 174
 175     $leaks_found++;
 176     $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
 177
 178     my $diag = do {
 179       local $Data::Dumper::Maxdepth = 1;
 180       sprintf "\n%s (refcnt %d) => %s\n",
 181         $weak_registry->{$addr}{display_name},
 182         refcount($weak_registry->{$addr}{weakref}),
 183         (
 184           ref($weak_registry->{$addr}{weakref}) eq 'CODE'
 185             and
 186           B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
 187         ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
 188       ;
 189     };
 190
 191     $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n"
 192       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 193
 194     $diag =~ s/^/    /mg;
 195
 196     if (my $stack = $weak_registry->{$addr}{stacktrace}) {
 197       $diag .= "    Reference first seen$stack";
 198     }
 199
 200     $tb->diag($diag);
 201   }
 202
 203   if (! $quiet and ! $leaks_found) {
 204     $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
 205   }
 206 }
 207
 208 END {
 209   if ($INC{'Test/Builder.pm'}) {
 210     my $tb = Test::Builder->new;
 211
 212     # we check for test passage - a leak may be a part of a TODO
 213     if ($leaks_found and !$tb->is_passing) {
 214
 215       $tb->diag(sprintf
 216         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 217       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 218       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 219       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 220
 221     }
 222     else {
 223       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 224     }
 225   }
 226 }
 227
 228 1;