Commit | Line | Data |
218b7c12 |
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 refaddr/; |
8fa57d17 |
8 | use B 'svref_2object'; |
218b7c12 |
9 | use DBICTest::Util 'stacktrace'; |
10 | |
11 | use base 'Exporter'; |
12 | our @EXPORT_OK = qw/populate_weakregistry assert_empty_weakregistry/; |
13 | |
14 | my $refs_traced = 0; |
15 | my $leaks_found; |
16 | my %reg_of_regs; |
17 | |
18 | sub populate_weakregistry { |
19 | my ($weak_registry, $target, $slot) = @_; |
20 | |
21 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
22 | croak 'Target is not a reference' unless length ref $target; |
23 | |
8fa57d17 |
24 | my $refaddr = refaddr $target; |
25 | |
218b7c12 |
26 | $slot ||= (sprintf '%s%s(0x%x)', # so we don't trigger stringification |
27 | (defined blessed $target) ? blessed($target) . '=' : '', |
28 | reftype $target, |
8fa57d17 |
29 | $refaddr, |
218b7c12 |
30 | ); |
31 | |
32 | if (defined $weak_registry->{$slot}{weakref}) { |
8fa57d17 |
33 | if ( $weak_registry->{$slot}{refaddr} != $refaddr ) { |
34 | print STDERR "Bail out! Weak Registry slot collision $slot: $weak_registry->{$slot}{weakref} / $target\n"; |
218b7c12 |
35 | exit 255; |
36 | } |
37 | } |
38 | else { |
8fa57d17 |
39 | $weak_registry->{$slot} = { |
40 | stacktrace => stacktrace(1), |
41 | refaddr => $refaddr, |
42 | renumber => $_[2] ? 0 : 1, |
43 | }; |
218b7c12 |
44 | weaken( $weak_registry->{$slot}{weakref} = $target ); |
8fa57d17 |
45 | $refs_traced++; |
218b7c12 |
46 | } |
47 | |
48 | weaken( $reg_of_regs{ refaddr($weak_registry) } = $weak_registry ) |
49 | unless( $reg_of_regs{ refaddr($weak_registry) } ); |
50 | |
51 | $target; |
52 | } |
53 | |
54 | # Renumber everything we auto-named on a thread spawn |
55 | sub CLONE { |
56 | my @individual_regs = grep { scalar keys %{$_||{}} } values %reg_of_regs; |
57 | %reg_of_regs = (); |
58 | |
59 | for my $reg (@individual_regs) { |
60 | my @live_slots = grep { defined $reg->{$_}{weakref} } keys %$reg |
61 | or next; |
cf8fa286 |
62 | |
218b7c12 |
63 | my @live_instances = @{$reg}{@live_slots}; |
64 | |
cf8fa286 |
65 | $reg = {}; # get a fresh hashref in the new thread ctx |
218b7c12 |
66 | weaken( $reg_of_regs{refaddr($reg)} = $reg ); |
67 | |
68 | while (@live_slots) { |
69 | my $slot = shift @live_slots; |
70 | my $inst = shift @live_instances; |
71 | |
8fa57d17 |
72 | my $refaddr = $inst->{refaddr} = refaddr($inst); |
73 | |
74 | $slot =~ s/0x[0-9A-F]+/'0x' . sprintf ('0x%x', $refaddr)/ieg |
218b7c12 |
75 | if $inst->{renumber}; |
76 | |
77 | $reg->{$slot} = $inst; |
78 | } |
79 | } |
80 | } |
81 | |
82 | sub assert_empty_weakregistry { |
83 | my ($weak_registry, $quiet) = @_; |
84 | |
85 | croak 'Expecting a registry hashref' unless ref $weak_registry eq 'HASH'; |
86 | |
87 | return unless keys %$weak_registry; |
88 | |
89 | my $tb = eval { Test::Builder->new } |
90 | or croak 'Calling test_weakregistry without a loaded Test::Builder makes no sense'; |
91 | |
92 | for my $slot (sort keys %$weak_registry) { |
93 | next if ! defined $weak_registry->{$slot}{weakref}; |
94 | $tb->BAILOUT("!!!! WEAK REGISTRY SLOT $slot IS NOT A WEAKREF !!!!") |
95 | unless isweak( $weak_registry->{$slot}{weakref} ); |
96 | } |
97 | |
98 | |
8fa57d17 |
99 | # compile a list of refs stored as CAG class data, so we can skip them |
100 | # intelligently below |
101 | my ($classdata_refcounts, $symwalker, $refwalker); |
102 | |
103 | $refwalker = sub { |
104 | return unless length ref $_[0]; |
105 | |
106 | my $seen = $_[1] || {}; |
107 | return if $seen->{refaddr $_[0]}++; |
108 | |
109 | $classdata_refcounts->{refaddr $_[0]}++; |
110 | |
111 | my $type = reftype $_[0]; |
112 | if ($type eq 'HASH') { |
113 | $refwalker->($_, $seen) for values %{$_[0]}; |
114 | } |
115 | elsif ($type eq 'ARRAY') { |
116 | $refwalker->($_, $seen) for @{$_[0]}; |
117 | } |
118 | elsif ($type eq 'REF') { |
119 | $refwalker->($$_, $seen); |
120 | } |
121 | }; |
122 | |
123 | $symwalker = sub { |
124 | no strict 'refs'; |
125 | my $pkg = shift || '::'; |
126 | |
127 | $refwalker->(${"${pkg}$_"}) for grep { $_ =~ /__cag_(?!pkg_gen__|supers__)/ } keys %$pkg; |
128 | |
129 | $symwalker->("${pkg}$_") for grep { $_ =~ /(?<!^main)::$/ } keys %$pkg; |
130 | }; |
131 | |
132 | # run things twice, some cycles will be broken, introducing new |
133 | # candidates for pseudo-GC |
134 | for (1,2) { |
135 | undef $classdata_refcounts; |
136 | |
137 | $symwalker->(); |
138 | |
139 | for my $slot (keys %$weak_registry) { |
140 | if ( |
141 | defined $weak_registry->{$slot}{weakref} |
142 | and |
143 | my $expected_refcnt = $classdata_refcounts->{$weak_registry->{$slot}{refaddr}} |
144 | ) { |
145 | # need to store the SVref and examine it separately, |
146 | # to push the weakref instance off the pad |
147 | my $sv = svref_2object($weak_registry->{$slot}{weakref}); |
148 | delete $weak_registry->{$slot} if $sv->REFCNT == $expected_refcnt; |
149 | } |
150 | } |
151 | } |
152 | |
218b7c12 |
153 | for my $slot (sort keys %$weak_registry) { |
154 | ! defined $weak_registry->{$slot}{weakref} and next if $quiet; |
155 | |
156 | $tb->ok (! defined $weak_registry->{$slot}{weakref}, "No leaks of $slot") or do { |
157 | $leaks_found = 1; |
158 | |
159 | my $diag = ''; |
160 | |
161 | $diag .= Devel::FindRef::track ($weak_registry->{$slot}{weakref}, 20) . "\n" |
162 | if ( $ENV{TEST_VERBOSE} && eval { require Devel::FindRef }); |
163 | |
164 | if (my $stack = $weak_registry->{$slot}{stacktrace}) { |
165 | $diag .= " Reference first seen$stack"; |
166 | } |
167 | |
168 | $tb->diag($diag) if $diag; |
169 | }; |
170 | } |
171 | } |
172 | |
173 | END { |
174 | if ($INC{'Test/Builder.pm'}) { |
175 | my $tb = Test::Builder->new; |
176 | |
177 | # we check for test passage - a leak may be a part of a TODO |
178 | if ($leaks_found and !$tb->is_passing) { |
179 | |
180 | $tb->diag(sprintf |
181 | "\n\n%s\n%s\n\nInstall Devel::FindRef and re-run the test with set " |
182 | . '$ENV{TEST_VERBOSE} (prove -v) to see a more detailed leak-report' |
183 | . "\n\n%s\n%s\n\n", ('#' x 16) x 4 |
184 | ) if ( !$ENV{TEST_VERBOSE} or !$INC{'Devel/FindRef.pm'} ); |
185 | |
186 | } |
187 | else { |
188 | $tb->note("Auto checked $refs_traced references for leaks - none detected"); |
189 | } |
190 | } |
191 | } |
192 | |
193 | 1; |