Commit | Line | Data |
218b7c12 |
1 | package DBICTest::Util::LeakTracer; |
2 | |
3 | use warnings; |
4 | use strict; |
5 | |
6 | use Carp; |
96577657 |
7 | use Scalar::Util qw(isweak weaken blessed reftype); |
dac7972a |
8 | use DBIx::Class::_Util 'refcount'; |
556c4fe6 |
9 | use DBIx::Class::Optional::Dependencies; |
96577657 |
10 | use Data::Dumper::Concise; |
218b7c12 |
11 | use DBICTest::Util 'stacktrace'; |
556c4fe6 |
12 | use constant { |
13 | CV_TRACING => DBIx::Class::Optional::Dependencies->req_ok_for ('test_leaks_heavy'), |
14 | }; |
218b7c12 |
15 | |
16 | use base 'Exporter'; |
21aa86aa |
17 | our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr visit_refs); |
218b7c12 |
18 | |
19 | my $refs_traced = 0; |
96577657 |
20 | my $leaks_found = 0; |
218b7c12 |
21 | my %reg_of_regs; |
22 | |
96577657 |
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 | |
218b7c12 |
34 | sub populate_weakregistry { |
96577657 |
35 | my ($weak_registry, $target, $note) = @_; |
218b7c12 |
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 | |
96577657 |
40 | my $refaddr = hrefaddr $target; |
8fa57d17 |
41 | |
96577657 |
42 | # a registry could be fed to itself or another registry via recursive sweeps |
43 | return $target if $reg_of_regs{$refaddr}; |
218b7c12 |
44 | |
85ad63df |
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 | |
96577657 |
56 | if (! defined $weak_registry->{$refaddr}{weakref}) { |
57 | $weak_registry->{$refaddr} = { |
8fa57d17 |
58 | stacktrace => stacktrace(1), |
96577657 |
59 | weakref => $target, |
8fa57d17 |
60 | }; |
96577657 |
61 | weaken( $weak_registry->{$refaddr}{weakref} ); |
8fa57d17 |
62 | $refs_traced++; |
218b7c12 |
63 | } |
64 | |
96577657 |
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 | |
218b7c12 |
72 | $target; |
73 | } |
74 | |
96577657 |
75 | # Regenerate the slots names on a thread spawn |
218b7c12 |
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) { |
96577657 |
81 | my @live_slots = grep { defined $_->{weakref} } values %$reg |
218b7c12 |
82 | or next; |
cf8fa286 |
83 | |
cf8fa286 |
84 | $reg = {}; # get a fresh hashref in the new thread ctx |
96577657 |
85 | weaken( $reg_of_regs{hrefaddr($reg)} = $reg ); |
218b7c12 |
86 | |
96577657 |
87 | for my $slot_info (@live_slots) { |
88 | my $new_addr = hrefaddr $slot_info->{weakref}; |
8fa57d17 |
89 | |
96577657 |
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}} }; |
218b7c12 |
96 | |
96577657 |
97 | $reg->{$new_addr} = $slot_info; |
218b7c12 |
98 | } |
99 | } |
100 | } |
101 | |
556c4fe6 |
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 | |
218b7c12 |
143 | sub assert_empty_weakregistry { |
144 | my ($weak_registry, $quiet) = @_; |
145 | |
556c4fe6 |
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 | |
218b7c12 |
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 } |
556c4fe6 |
156 | or croak "Calling assert_empty_weakregistry in $0 without a loaded Test::Builder makes no sense"; |
218b7c12 |
157 | |
96577657 |
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 | ); |
218b7c12 |
164 | |
96577657 |
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 | } |
218b7c12 |
168 | |
556c4fe6 |
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 | }; |
8fa57d17 |
208 | |
209 | $symwalker->(); |
210 | |
556c4fe6 |
211 | # use Devel::Dwarn; |
212 | # Ddie [ map |
213 | # { { $_ => $symcounts->{$_} } } |
214 | # sort |
215 | # {$symcounts->{$a} <=> $symcounts->{$b} } |
216 | # keys %$symcounts |
217 | # ]; |
8fa57d17 |
218 | } |
219 | |
556c4fe6 |
220 | delete $weak_registry->{$_} for keys %$classdata_refs; |
221 | |
96577657 |
222 | for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { |
223 | |
1a44a267 |
224 | next if ! defined $weak_registry->{$addr}{weakref}; |
225 | |
5dc4301c |
226 | $leaks_found++ unless $tb->in_todo; |
1a44a267 |
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 | ; |
218b7c12 |
240 | }; |
1a44a267 |
241 | |
5dc4301c |
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 | |
556c4fe6 |
245 | $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 50) . "\n" |
1a44a267 |
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 | |
5dc4301c |
257 | if (! $quiet and !$leaks_found and ! $tb->in_todo) { |
1a44a267 |
258 | $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); |
218b7c12 |
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; |