t/lib/DBICTest/Util/LeakTracer.pm

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