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'; |
96577657 |
9 | use Data::Dumper::Concise; |
218b7c12 |
10 | use DBICTest::Util 'stacktrace'; |
11 | |
12 | use base 'Exporter'; |
96577657 |
13 | our @EXPORT_OK = qw(populate_weakregistry assert_empty_weakregistry hrefaddr); |
218b7c12 |
14 | |
15 | my $refs_traced = 0; |
96577657 |
16 | my $leaks_found = 0; |
218b7c12 |
17 | my %reg_of_regs; |
18 | |
96577657 |
19 | sub hrefaddr { sprintf '0x%x', &Scalar::Util::refaddr } |
20 | |
21 | # so we don't trigger stringification |
22 | sub _describe_ref { |
23 | sprintf '%s%s(%s)', |
24 | (defined blessed $_[0]) ? blessed($_[0]) . '=' : '', |
25 | reftype $_[0], |
26 | hrefaddr $_[0], |
27 | ; |
28 | } |
29 | |
218b7c12 |
30 | sub populate_weakregistry { |
96577657 |
31 | my ($weak_registry, $target, $note) = @_; |
218b7c12 |
32 | |
33 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
34 | croak 'Target is not a reference' unless length ref $target; |
35 | |
96577657 |
36 | my $refaddr = hrefaddr $target; |
8fa57d17 |
37 | |
96577657 |
38 | # a registry could be fed to itself or another registry via recursive sweeps |
39 | return $target if $reg_of_regs{$refaddr}; |
218b7c12 |
40 | |
85ad63df |
41 | weaken( $reg_of_regs{ hrefaddr($weak_registry) } = $weak_registry ) |
42 | unless( $reg_of_regs{ hrefaddr($weak_registry) } ); |
43 | |
44 | # an explicit "garbage collection" pass every time we store a ref |
45 | # if we do not do this the registry will keep growing appearing |
46 | # as if the traced program is continuously slowly leaking memory |
47 | for my $reg (values %reg_of_regs) { |
48 | (defined $reg->{$_}{weakref}) or delete $reg->{$_} |
49 | for keys %$reg; |
50 | } |
51 | |
96577657 |
52 | if (! defined $weak_registry->{$refaddr}{weakref}) { |
53 | $weak_registry->{$refaddr} = { |
8fa57d17 |
54 | stacktrace => stacktrace(1), |
96577657 |
55 | weakref => $target, |
8fa57d17 |
56 | }; |
96577657 |
57 | weaken( $weak_registry->{$refaddr}{weakref} ); |
8fa57d17 |
58 | $refs_traced++; |
218b7c12 |
59 | } |
60 | |
96577657 |
61 | my $desc = _describe_ref($target); |
62 | $weak_registry->{$refaddr}{slot_names}{$desc} = 1; |
63 | if ($note) { |
64 | $note =~ s/\s*\Q$desc\E\s*//g; |
65 | $weak_registry->{$refaddr}{slot_names}{$note} = 1; |
66 | } |
67 | |
218b7c12 |
68 | $target; |
69 | } |
70 | |
96577657 |
71 | # Regenerate the slots names on a thread spawn |
218b7c12 |
72 | sub CLONE { |
73 | my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; |
74 | %reg_of_regs = (); |
75 | |
76 | for my $reg (@individual_regs) { |
96577657 |
77 | my @live_slots = grep { defined $_->{weakref} } values %$reg |
218b7c12 |
78 | or next; |
cf8fa286 |
79 | |
cf8fa286 |
80 | $reg = {}; # get a fresh hashref in the new thread ctx |
96577657 |
81 | weaken( $reg_of_regs{hrefaddr($reg)} = $reg ); |
218b7c12 |
82 | |
96577657 |
83 | for my $slot_info (@live_slots) { |
84 | my $new_addr = hrefaddr $slot_info->{weakref}; |
8fa57d17 |
85 | |
96577657 |
86 | # replace all slot names |
87 | $slot_info->{slot_names} = { map { |
88 | my $name = $_; |
89 | $name =~ s/\(0x[0-9A-F]+\)/sprintf ('(%s)', $new_addr)/ieg; |
90 | ($name => 1); |
91 | } keys %{$slot_info->{slot_names}} }; |
218b7c12 |
92 | |
96577657 |
93 | $reg->{$new_addr} = $slot_info; |
218b7c12 |
94 | } |
95 | } |
96 | } |
97 | |
98 | sub assert_empty_weakregistry { |
99 | my ($weak_registry, $quiet) = @_; |
100 | |
101 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
102 | |
103 | return unless keys %$weak_registry; |
104 | |
105 | my $tb = eval { Test::Builder->new } |
106 | or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; |
107 | |
96577657 |
108 | for my $addr (keys %$weak_registry) { |
109 | $weak_registry->{$addr}{display_name} = join ' | ', ( |
110 | sort |
111 | { length $a <=> length $b or $a cmp $b } |
112 | keys %{$weak_registry->{$addr}{slot_names}} |
113 | ); |
218b7c12 |
114 | |
96577657 |
115 | $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $weak_registry->{$addr}{display_name} IS NOT A WEAKREF !!!!") |
116 | if defined $weak_registry->{$addr}{weakref} and ! isweak( $weak_registry->{$addr}{weakref} ); |
117 | } |
218b7c12 |
118 | |
8fa57d17 |
119 | # compile a list of refs stored as CAG class data, so we can skip them |
120 | # intelligently below |
121 | my ($classdata_refcounts, $symwalker, $refwalker); |
122 | |
123 | $refwalker = sub { |
124 | return unless length ref $_[0]; |
125 | |
126 | my $seen = $_[1] || {}; |
96577657 |
127 | return if $seen->{hrefaddr $_[0]}++; |
8fa57d17 |
128 | |
96577657 |
129 | $classdata_refcounts->{hrefaddr $_[0]}++; |
8fa57d17 |
130 | |
131 | my $type = reftype $_[0]; |
132 | if ($type eq 'HASH') { |
133 | $refwalker->($_, $seen) for values %{$_[0]}; |
134 | } |
135 | elsif ($type eq 'ARRAY') { |
136 | $refwalker->($_, $seen) for @{$_[0]}; |
137 | } |
138 | elsif ($type eq 'REF') { |
139 | $refwalker->($$_, $seen); |
140 | } |
141 | }; |
142 | |
143 | $symwalker = sub { |
144 | no strict 'refs'; |
145 | my $pkg = shift || '::'; |
146 | |
147 | $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg; |
148 | |
149 | $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg; |
150 | }; |
151 | |
152 | # run things twice, some cycles will be broken, introducing new |
153 | # candidates for pseudo-GC |
154 | for (1,2) { |
155 | undef $classdata_refcounts; |
156 | |
157 | $symwalker->(); |
158 | |
96577657 |
159 | for my $refaddr (keys %$weak_registry) { |
8fa57d17 |
160 | if ( |
96577657 |
161 | defined $weak_registry->{$refaddr}{weakref} |
8fa57d17 |
162 | and |
96577657 |
163 | my $expected_refcnt = $classdata_refcounts->{$refaddr} |
8fa57d17 |
164 | ) { |
96577657 |
165 | delete $weak_registry->{$refaddr} |
166 | if refcount($weak_registry->{$refaddr}{weakref}) == $expected_refcnt; |
8fa57d17 |
167 | } |
168 | } |
169 | } |
170 | |
96577657 |
171 | for my $addr (sort { $weak_registry->{$a}{display_name} cmp $weak_registry->{$b}{display_name} } keys %$weak_registry) { |
172 | |
1a44a267 |
173 | next if ! defined $weak_registry->{$addr}{weakref}; |
174 | |
175 | $leaks_found++; |
176 | $tb->ok (0, "Leaked $weak_registry->{$addr}{display_name}"); |
177 | |
178 | my $diag = do { |
179 | local $Data::Dumper::Maxdepth = 1; |
180 | sprintf "\n%s (refcnt %d) => %s\n", |
181 | $weak_registry->{$addr}{display_name}, |
182 | refcount($weak_registry->{$addr}{weakref}), |
183 | ( |
184 | ref($weak_registry->{$addr}{weakref}) eq 'CODE' |
185 | and |
186 | B::svref_2object($weak_registry->{$addr}{weakref})->XSUB |
187 | ) ? '__XSUB__' : Dumper( $weak_registry->{$addr}{weakref} ) |
188 | ; |
218b7c12 |
189 | }; |
1a44a267 |
190 | |
191 | $diag .= Devel::FindRef::track ($weak_registry->{$addr}{weakref}, 20) . "\n" |
192 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
193 | |
194 | $diag =~ s/^/ /mg; |
195 | |
196 | if (my $stack = $weak_registry->{$addr}{stacktrace}) { |
197 | $diag .= " Reference first seen$stack"; |
198 | } |
199 | |
200 | $tb->diag($diag); |
201 | } |
202 | |
203 | if (! $quiet and ! $leaks_found) { |
204 | $tb->ok(1, sprintf "No leaks found at %s line %d", (caller())[1,2] ); |
218b7c12 |
205 | } |
206 | } |
207 | |
208 | END { |
209 | if ($INC{'Test/Builder.pm'}) { |
210 | my $tb = Test::Builder->new; |
211 | |
212 | # we check for test passage - a leak may be a part of a TODO |
213 | if ($leaks_found and !$tb->is_passing) { |
214 | |
215 | $tb->diag(sprintf |
216 | "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " |
217 | . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' |
218 | . "\n\n%s\n%s\n\n", ('#' x 16) x 4 |
219 | ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); |
220 | |
221 | } |
222 | else { |
223 | $tb->note("Auto checked $refs_traced references for leaks - none detected"); |
224 | } |
225 | } |
226 | } |
227 | |
228 | 1; |