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