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