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