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   defined $weak_registry->{$_}{weakref} or delete $weak_registry->{$_}
 170     for keys %$weak_registry;
 171
 172   return unless keys %$weak_registry;
 173
 174   my $tb = eval { Test::Builder->new }
 175     or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense";
 176
 177   for my $addr (keys %$weak_registry) {
 178     $weak_registry->{$addr}{display_name} = join ' | ', (
 179       sort
 180         { length $a <=> length $b or $a cmp $b }
 181         keys %{$weak_registry->{$addr}{slot_names}}
 182     );
 183
 184     $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!")
 185       if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} );
 186   }
 187
 188   # compile a list of refs stored as globals (possibly even catching
 189   # class data in the form of method closures), so we can skip them
 190   # further on
 191   my ($seen_refs, $classdata_refs) = ({}, undef);
 192
 193   # the walk is very expensive - if we are $quiet (running in an END block)
 194   # we do not really need to be too thorough
 195   unless ($quiet) {
 196     my ($symwalker, $symcounts);
 197     $symwalker = sub {
 198       no strict 'refs';
 199       my $pkg = shift || '::';
 200
 201       # any non-weak globals are "clasdata" in all possible sense
 202       #
 203       # the unless regex at the end skips some dangerous namespaces outright
 204       # (but does not prevent descent)
 205       $symcounts->{$pkg} += visit_refs (
 206         seen_refs => $seen_refs,
 207         action => sub { ++$classdata_refs->{hrefaddr $_[0]} },
 208         refs => [ map { my $sym = $_;
 209           # *{"$pkg$sym"}{CODE} won't simply work - MRO-cached CVs are invisible there
 210           ( CV_TRACING ? Class::MethodCache::get_cv("${pkg}$sym") : () ),
 211
 212           ( defined *{"$pkg$sym"}{SCALAR} and length ref ${"$pkg$sym"} and ! isweak( ${"$pkg$sym"} ) )
 213             ? ${"$pkg$sym"} : ()
 214           ,
 215           ( map {
 216             ( defined *{"$pkg$sym"}{$_} and ! isweak(defined *{"$pkg$sym"}{$_}) )
 217               ? *{"$pkg$sym"}{$_}
 218               : ()
 219           } qw(HASH ARRAY IO GLOB) ),
 220         } keys %$pkg ],
 221       ) unless $pkg =~ /^ :: (?:
 222         DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
 223       ) :: $/x;
 224
 225       $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg;
 226     };
 227
 228     $symwalker->();
 229
 230 #    use Devel::Dwarn;
 231 #    Ddie [ map
 232 #      { { $_ => $symcounts->{$_} } }
 233 #      sort
 234 #        {$symcounts->{$a} <=> $symcounts->{$b} }
 235 #        keys %$symcounts
 236 #    ];
 237   }
 238
 239   delete $weak_registry->{$_} for keys %$classdata_refs;
 240
 241   for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) {
 242
 243     next if ! defined $weak_registry->{$addr}{weakref};
 244
 245     $leaks_found++ unless $tb->in_todo;
 246     $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}");
 247
 248     my $diag = do {
 249       local $Data::Dumper::Maxdepth = 1;
 250       sprintf "\n%s (refcnt %d) => %s\n",
 251         $weak_registry->{$addr}{display_name},
 252         refcount($weak_registry->{$addr}{weakref}),
 253         (
 254           ref($weak_registry->{$addr}{weakref}) eq 'CODE'
 255             and
 256           B::svref_2object($weak_registry->{$addr}{weakref})->XSUB
 257         ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} )
 258       ;
 259     };
 260
 261     # FIXME - need to add a circular reference seeker based on the visitor
 262     # (will need a bunch of modifications, punting with just a stub for now)
 263
 264     $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n"
 265       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
 266
 267     $diag =~ s/^/    /mg;
 268
 269     if (my $stack = $weak_registry->{$addr}{stacktrace}) {
 270       $diag .= "    Reference first seen$stack";
 271     }
 272
 273     $tb->diag($diag);
 274
 275 #    if ($leaks_found == 1) {
 276 #      # using the fh dumper due to intermittent buffering issues
 277 #      # in case we decide to exit soon after (possibly via _exit)
 278 #      require Devel::MAT::Dumper;
 279 #      local $Devel::MAT::Dumper::MAX_STRING = -1;
 280 #      open( my $fh, '>:raw', "leaked_${addr}_pid$$.pmat" ) or die $!;
 281 #      Devel::MAT::Dumper::dumpfh( $fh );
 282 #      close ($fh) or die $!;
 283 #
 284 #      use POSIX;
 285 #      POSIX::_exit(1);
 286 #    }
 287   }
 288
 289   if (! $quiet and !$leaks_found and ! $tb->in_todo) {
 290     $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
 291   }
 292 }
 293
 294 END {
 295   if ($INC{'Test/Builder.pm'}) {
 296     my $tb = Test::Builder->new;
 297
 298     # we check for test passage - a leak may be a part of a TODO
 299     if ($leaks_found and !$tb->is_passing) {
 300
 301       $tb->diag(sprintf
 302         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
 303       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
 304       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
 305       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
 306
 307     }
 308     else {
 309       $tb->note("Auto checked $refs_traced references for leaks - none detected");
 310     }
 311   }
 312 }
 313
 314 1;