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
 113     next unless length ref $args->{refs}[$i]; # not-a-ref
 114
 115     my $addr = hrefaddr $args->{refs}[$i];
 116
 117     # no diving into weakregistries
 118     next if $reg_of_regs{$addr};
 119
 120     next if $args->{seen_refs}{$addr}++;
 121     $visited_cnt++;
 122
 123     my $r = $args->{refs}[$i];
 124
 125     $args->{action}->($r) or next;
 126
 127     # This may end up being necessarry some day, but do not slow things
 128     # down for now
 129     #if ( defined( my $t = tied($r) ) ) {
 130     #  $visited_cnt += visit_refs({ %$args, refs => [ $t ] });
 131     #}
 132
 133     my $type = reftype $r;
 134
 135     local $@;
 136     eval {
 137       if ($type eq 'HASH') {
 138         $visited_cnt += visit_refs({ %$args, refs => [ map {
 139           ( !isweak($r->{$_}) ) ? $r->{$_} : ()
 140         } keys %$r ] });
 141       }
 142       elsif ($type eq 'ARRAY') {
 143         $visited_cnt += visit_refs({ %$args, refs => [ map {
 144           ( !isweak($r->[$_]) ) ? $r->[$_] : ()
 145         } 0..$#$r ] });
 146       }
 147       elsif ($type eq 'REF' and !isweak($$r)) {
 148         $visited_cnt += visit_refs({ %$args, refs => [ $$r ] });
 149       }
 150       elsif (CV_TRACING and $type eq 'CODE') {
 151         $visited_cnt += visit_refs({ %$args, refs => [ map {
 152           ( !isweak($_) ) ? $_ : ()
 153         } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269
 154       }
 155       1;
 156     } or warn "Could not descend into @{[ _describe_ref($r) ]}: $@\n";
 157   }
 158   $visited_cnt;
 159 }
 160
 161 sub visit_namespaces {
 162   my $args = { (ref $_[0]) ? %{$_[0]} : @_ };
 163
 164   my $visited = 1;
 165
 166   $args->{package} ||= '::';
 167   $args->{package} = '::' if $args->{package} eq 'main';
 168
 169   if ( $args->{action}->($args->{package}) ) {
 170
 171     my $base = $args->{package};
 172     $base = '' if $base eq '::';
 173
 174
 175     $visited += visit_namespaces({ %$args, package => $_ }) for map
 176       { $_ =~ /(.+?)::$/ && "${base}::$1" }
 177       grep
 178         { $_ =~ /(?<!^main)::$/ }
 179         do {  no strict 'refs'; keys %{ $base . '::'} }
 180   }
 181
 182   return $visited;
 183 }
 184
 185 # compiles a list of addresses stored as globals (possibly even catching
 186 # class data in the form of method closures), so we can skip them further on
 187 sub symtable_referenced_addresses {
 188
 189   my $refs_per_pkg;
 190
 191   my $dummy_addresslist;
 192
 193   my $seen_refs = {};
 194   visit_namespaces(
 195     action => sub {
 196
 197       no strict 'refs';
 198
 199       my $pkg = shift;
 200       $pkg = '' if $pkg eq '::';
 201       $pkg .= '::';
 202
 203       # the unless regex at the end skips some dangerous namespaces outright
 204       # (but does not prevent descent)
 205       $refs_per_pkg->{$pkg} += visit_refs (
 206         seen_refs => $seen_refs,
 207
 208         # FIXME FIXME FIXME
 209         # This is so damn odd - if we feed a constsub {1} (or in fact almost
 210         # anything other than the actionsub below, any scalarref will show
 211         # up as a leak, trapped by... something...
 212         # Ideally we should be able to const this to sub{1} and just return
 213         # $seen_refs (in fact it is identical to the dummy list at the end of
 214         # a run here). Alas this doesn't seem to work, so punt for now...
 215         action => sub { ++$dummy_addresslist->{ hrefaddr $_[0] } },
 216
 217         refs => [ map { my $sym = $_;
 218           # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
 219           ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
 220
 221           ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
 222             ? ${"$pkg$sym"} : ()
 223           ,
 224
 225           ( map {
 226             ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
 227               ? *{"$pkg$sym"}{$_}
 228               : ()
 229           } qw(HASH ARRAY IO GLOB) ),
 230
 231         } keys %$pkg ],
 232       ) unless $pkg =~ /^ :: (?:
 233         DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
 234       ) :: $/x;
 235     }
 236   );
 237
 238 #  use Devel::Dwarn;
 239 #  Ddie [ map
 240 #    { { $_ => $refs_per_pkg->{$_} } }
 241 #    sort
 242 #      {$refs_per_pkg->{$a} <=> $refs_per_pkg->{$b} }
 243 #      keys %$refs_per_pkg
 244 #  ];
 245
 246   $seen_refs;
 247 }
 248
 249 sub assert_empty_weakregistry {
 250   my ($weak_registry, $quiet) = @_;
 251
 252   # in case we hooked bless any extra object creation will wreak
 253   # havoc during the assert phase
 254   local *CORE::GLOBAL::bless;
 255   *CORE::GLOBAL::bless = sub { CORE::bless( $_[0], (@_ > 1) ? $_[1] : caller() ) };
 256
 257   croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH';
 258
 259   defined $weak_registry->{$_}{weakref} or delete $weak_registry->{$_}
 260     for keys %$weak_registry;
 261
 262   return unless keys %$weak_registry;
 263
 264   my $tb = eval { Test::Builder->new }
 265     or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense";
 266
 267   for my $addr (keys %$weak_registry) {
 268     $weak_registry->{$addr}{display_name} = join ' | ', (
 269       sort
 270         { length $a <=> length $b or $a cmp $b }
 271         keys %{$weak_registry->{$addr}{slot_names}}
 272     );
 273
 274     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
 275       if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
 276   }
 277
 278   # the walk is very expensive - if we are $quiet (running in an END block)
 279   # we do not really need to be too thorough
 280   unless ($quiet) {
 281     delete $weak_registry->{$_} for keys %{ symtable_referenced_addresses() };
 282   }
 283
 284
 285   for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
 286
 287     next if ! defined $weak_registry->{$addr}{weakref};
 288
 289     $leaks_found++ unless $tb->in_todo;
 290     $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
 291
 292     my $diag = do {
 293       local $Data::Dumper::Maxdepth = 1;
 294       sprintf "\n%s (refcnt %d) => %s\n",
 295         $weak_registry->{$addr}{display_name},
 296         refcount($weak_registry->{$addr}{weakref}),
 297         (
 298           ref($weak_registry->{$addr}{weakref}) eq 'CODE'
 299             and
 300           B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
 301         ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
 302       ;
 303     };
 304
 305     # FIXME - need to add a circular reference seeker based on the visitor
 306     # (will need a bunch of modifications, punting with just a stub for now)
 307
 308     $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n"
 309       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 310
 311     $diag =~ s/^/    /mg;
 312
 313     if (my $stack = $weak_registry->{$addr}{stacktrace}) {
 314       $diag .= "    Reference first seen$stack";
 315     }
 316
 317     $tb->diag($diag);
 318
 319 #    if ($leaks_found == 1) {
 320 #      # using the fh dumper due to intermittent buffering issues
 321 #      # in case we decide to exit soon after (possibly via _exit)
 322 #      require Devel::MAT::Dumper;
 323 #      local $Devel::MAT::Dumper::MAX_STRING = -1;
 324 #      open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!;
 325 #      Devel::MAT::Dumper::dumpfh( $fh );
 326 #      close ($fh) or die $!;
 327 #
 328 #      use POSIX;
 329 #      POSIX::_exit(1);
 330 #    }
 331   }
 332
 333   if (! $quiet and !$leaks_found and ! $tb->in_todo) {
 334     $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
 335   }
 336 }
 337
 338 END {
 339   if ($INC{'Test/Builder.pm'}) {
 340     my $tb = Test::Builder->new;
 341
 342     # we check for test passage - a leak may be a part of a TODO
 343     if ($leaks_found and !$tb->is_passing) {
 344
 345       $tb->diag(sprintf
 346         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 347       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 348       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 349       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 350
 351     }
 352     else {
 353       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 354     }
 355   }
 356 }
 357
 358 1;