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 qw(refcount hrefaddr);
   9 use DBIx::Class::Optional::Dependencies;
  10 use Data::Dumper::Concise;
  11 use DBICTest::Util 'stacktrace';
  12 use constant {
  13   CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'),
  14   SKIP_SCALAR_REFS => ( $] > 5.017 ) ? 1 : 0,
  15 };
  16
  17 use base 'Exporter';
  18 our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry visit_refs);
  19
  20 my $refs_traced = 0;
  21 my $leaks_found = 0;
  22 my %reg_of_regs;
  23
  24 # so we don't trigger stringification
  25 sub _describe_ref {
  26   sprintf '%s%s(%s)',
  27     (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
  28     reftype $_[0],
  29     hrefaddr $_[0],
  30   ;
  31 }
  32
  33 sub populate_weakregistry {
  34   my ($weak_registry, $target, $note) = @_;
  35
  36   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
  37   croak 'Target is not a reference' unless length ref $target;
  38
  39   my $refaddr = hrefaddr $target;
  40
  41   # a registry could be fed to itself or another registry via recursive sweeps
  42   return $target if $reg_of_regs{$refaddr};
  43
  44   weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry )
  45     unless( $reg_of_regs{ hrefaddr($weak_registry) } );
  46
  47   # an explicit "garbage collection" pass every time we store a ref
  48   # if we do not do this the registry will keep growing appearing
  49   # as if the traced program is continuously slowly leaking memory
  50   for my $reg (values %reg_of_regs) {
  51     (defined $reg->{$_}{weakref}) or delete $reg->{$_}
  52       for keys %$reg;
  53   }
  54
  55   # FIXME/INVESTIGATE - something fishy is going on with refs to plain
  56   # strings, perhaps something to do with the CoW work etc...
  57   return $target if SKIP_SCALAR_REFS and reftype($target) eq 'SCALAR';
  58
  59   if (! defined $weak_registry->{$refaddr}{weakref}) {
  60     $weak_registry->{$refaddr} = {
  61       stacktrace => stacktrace(1),
  62       weakref => $target,
  63     };
  64     weaken( $weak_registry->{$refaddr}{weakref} );
  65     $refs_traced++;
  66   }
  67
  68   my $desc = _describe_ref($target);
  69   $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
  70   if ($note) {
  71     $note =~ s/\s*\Q$desc\E\s*//g;
  72     $weak_registry->{$refaddr}{slot_names}{$note} = 1;
  73   }
  74
  75   $target;
  76 }
  77
  78 # Regenerate the slots names on a thread spawn
  79 sub CLONE {
  80   my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs;
  81   %reg_of_regs = ();
  82
  83   for my $reg (@individual_regs) {
  84     my @live_slots = grep { defined $_->{weakref} } values %$reg
  85       or next;
  86
  87     $reg = {};  # get a fresh hashref in the new thread ctx
  88     weaken( $reg_of_regs{hrefaddr($reg)} = $reg );
  89
  90     for my $slot_info (@live_slots) {
  91       my $new_addr = hrefaddr $slot_info->{weakref};
  92
  93       # replace all slot names
  94       $slot_info->{slot_names} = { map {
  95         my $name = $_;
  96         $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg;
  97         ($name => 1);
  98       } keys %{$slot_info->{slot_names}} };
  99
 100       $reg->{$new_addr} = $slot_info;
 101     }
 102   }
 103 }
 104
 105 sub visit_refs {
 106   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 107
 108   $args->{seen_refs} ||= {};
 109
 110   my $visited_cnt = '0E0';
 111   for my $i (0 .. $#{$args->{refs}} ) {
 112     next if isweak($args->{refs}[$i]);
 113
 114     my $r = $args->{refs}[$i];
 115
 116     next unless length ref $r;
 117
 118     # no diving into weakregistries
 119     next if $reg_of_regs{hrefaddr $r};
 120
 121     next if $args->{seen_refs}{my $dec_addr = Scalar::Util::refaddr($r)}++;
 122
 123     $visited_cnt++;
 124     $args->{action}->($r) or next;
 125
 126     # This may end up being necessarry some day, but do not slow things
 127     # down for now
 128     #if ( defined( my $t = tied($r) ) ) {
 129     #  $visited_cnt += visit_refs({ %$args, refs => [ $t ] });
 130     #}
 131
 132     local $@;
 133     eval {
 134       my $type = reftype $r;
 135       if ($type eq 'HASH') {
 136         $visited_cnt += visit_refs({ %$args, refs => [ map {
 137           ( !isweak($r->{$_}) ) ? $r->{$_} : ()
 138         } keys %$r ] });
 139       }
 140       elsif ($type eq 'ARRAY') {
 141         $visited_cnt += visit_refs({ %$args, refs => [ map {
 142           ( !isweak($r->[$_]) ) ? $r->[$_] : ()
 143         } 0..$#$r ] });
 144       }
 145       elsif ($type eq 'REF' and !isweak($$r)) {
 146         $visited_cnt += visit_refs({ %$args, refs => [ $$r ] });
 147       }
 148       elsif (CV_TRACING and $type eq 'CODE') {
 149         $visited_cnt += visit_refs({ %$args, refs => [ map {
 150           ( !isweak($_) ) ? $_ : ()
 151         } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269
 152       }
 153       1;
 154     } or warn "Could not descend into @{[ _describe_ref($r) ]}: $@\n";
 155   }
 156   $visited_cnt;
 157 }
 158
 159 sub assert_empty_weakregistry {
 160   my ($weak_registry, $quiet) = @_;
 161
 162   # in case we hooked bless any extra object creation will wreak
 163   # havoc during the assert phase
 164   local *CORE::GLOBAL::bless;
 165   *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) };
 166
 167   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
 168
 169   return unless keys %$weak_registry;
 170
 171   my $tb = eval { Test::Builder->new }
 172     or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense";
 173
 174   for my $addr (keys %$weak_registry) {
 175     $weak_registry->{$addr}{display_name} = join ' | ', (
 176       sort
 177         { length $a <=> length $b or $a cmp $b }
 178         keys %{$weak_registry->{$addr}{slot_names}}
 179     );
 180
 181     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
 182       if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
 183   }
 184
 185   # compile a list of refs stored as globals (possibly even catching
 186   # class data in the form of method closures), so we can skip them
 187   # further on
 188   my ($seen_refs, $classdata_refs) = ({}, undef);
 189
 190   # the walk is very expensive - if we are $quiet (running in an END block)
 191   # we do not really need to be too thorough
 192   unless ($quiet) {
 193     my ($symwalker, $symcounts);
 194     $symwalker = sub {
 195       no strict 'refs';
 196       my $pkg = shift || '::';
 197
 198       # any non-weak globals are "clasdata" in all possible sense
 199       #
 200       # the unless regex at the end skips some dangerous namespaces outright
 201       # (but does not prevent descent)
 202       $symcounts->{$pkg} += visit_refs (
 203         seen_refs => $seen_refs,
 204         action => sub { ++$classdata_refs->{hrefaddr $_[0]} },
 205         refs => [ map { my $sym = $_;
 206           # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
 207           ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
 208
 209           ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
 210             ? ${"$pkg$sym"} : ()
 211           ,
 212           ( map {
 213             ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
 214               ? *{"$pkg$sym"}{$_}
 215               : ()
 216           } qw(HASH ARRAY IO GLOB) ),
 217         } keys %$pkg ],
 218       ) unless $pkg =~ /^ :: (?:
 219         DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
 220       ) :: $/x;
 221
 222       $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
 223     };
 224
 225     $symwalker->();
 226
 227 #    use Devel::Dwarn;
 228 #    Ddie [ map
 229 #      { { $_ => $symcounts->{$_} } }
 230 #      sort
 231 #        {$symcounts->{$a} <=> $symcounts->{$b} }
 232 #        keys %$symcounts
 233 #    ];
 234   }
 235
 236   delete $weak_registry->{$_} for keys %$classdata_refs;
 237
 238   for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
 239
 240     next if ! defined $weak_registry->{$addr}{weakref};
 241
 242     $leaks_found++ unless $tb->in_todo;
 243     $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
 244
 245     my $diag = do {
 246       local $Data::Dumper::Maxdepth = 1;
 247       sprintf "\n%s (refcnt %d) => %s\n",
 248         $weak_registry->{$addr}{display_name},
 249         refcount($weak_registry->{$addr}{weakref}),
 250         (
 251           ref($weak_registry->{$addr}{weakref}) eq 'CODE'
 252             and
 253           B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
 254         ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
 255       ;
 256     };
 257
 258     # FIXME - need to add a circular reference seeker based on the visitor
 259     # (will need a bunch of modifications, punting with just a stub for now)
 260
 261     $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n"
 262       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 263
 264     $diag =~ s/^/    /mg;
 265
 266     if (my $stack = $weak_registry->{$addr}{stacktrace}) {
 267       $diag .= "    Reference first seen$stack";
 268     }
 269
 270     $tb->diag($diag);
 271
 272 #    if ($leaks_found == 1) {
 273 #      # using the fh dumper due to intermittent buffering issues
 274 #      # in case we decide to exit soon after (possibly via _exit)
 275 #      require Devel::MAT::Dumper;
 276 #      local $Devel::MAT::Dumper::MAX_STRING = -1;
 277 #      open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!;
 278 #      Devel::MAT::Dumper::dumpfh( $fh );
 279 #      close ($fh) or die $!;
 280 #
 281 #      use POSIX;
 282 #      POSIX::_exit(1);
 283 #    }
 284   }
 285
 286   if (! $quiet and !$leaks_found and ! $tb->in_todo) {
 287     $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
 288   }
 289 }
 290
 291 END {
 292   if ($INC{'Test/Builder.pm'}) {
 293     my $tb = Test::Builder->new;
 294
 295     # we check for test passage - a leak may be a part of a TODO
 296     if ($leaks_found and !$tb->is_passing) {
 297
 298       $tb->diag(sprintf
 299         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 300       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 301       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 302       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 303
 304     }
 305     else {
 306       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 307     }
 308   }
 309 }
 310
 311 1;