Smoke 5.16.2 (ensure we are not affected by Encode leak) and bump latest 5.18
[dbsrgits/DBIx-Class-Historic.git] / 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 visit_refs);
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++ unless $tb->in_todo;
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     # FIXME - need to add a circular reference seeker based on the visitor
243     # (will need a bunch of modifications, punting with just a stub for now)
244
245     $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n"
246       if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef });
247
248     $diag =~ s/^/    /mg;
249
250     if (my $stack = $weak_registry->{$addr}{stacktrace}) {
251       $diag .= "    Reference first seen$stack";
252     }
253
254     $tb->diag($diag);
255   }
256
257   if (! $quiet and !$leaks_found and ! $tb->in_todo) {
258     $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] );
259   }
260 }
261
262 END {
263   if ($INC{'Test/Builder.pm'}) {
264     my $tb = Test::Builder->new;
265
266     # we check for test passage - a leak may be a part of a TODO
267     if ($leaks_found and !$tb->is_passing) {
268
269       $tb->diag(sprintf
270         "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set "
271       . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report'
272       . "\n\n%s\n%s\n\n", ('#' x 16) x 4
273       ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} );
274
275     }
276     else {
277       $tb->note("Auto checked $refs_traced references for leaks - none detected");
278     }
279   }
280 }
281
282 1;