line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::LeakGuard::Object; |
2
|
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
|
137421
|
use 5.008; |
|
6
|
|
|
|
|
25
|
|
|
6
|
|
|
|
|
249
|
|
4
|
|
|
|
|
|
|
|
5
|
6
|
|
|
6
|
|
34
|
use strict; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
398
|
|
6
|
6
|
|
|
6
|
|
32
|
use warnings; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
159
|
|
7
|
|
|
|
|
|
|
|
8
|
6
|
|
|
6
|
|
39
|
use Carp; |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
463
|
|
9
|
6
|
|
|
6
|
|
6474
|
use Data::Dumper; |
|
6
|
|
|
|
|
64770
|
|
|
6
|
|
|
|
|
502
|
|
10
|
6
|
|
|
6
|
|
46
|
use Scalar::Util qw( blessed refaddr weaken ); |
|
6
|
|
|
|
|
11
|
|
|
6
|
|
|
|
|
789
|
|
11
|
|
|
|
|
|
|
|
12
|
6
|
|
|
6
|
|
3167
|
use Devel::LeakGuard::Object::State; |
|
6
|
|
|
|
|
26
|
|
|
6
|
|
|
|
|
200
|
|
13
|
|
|
|
|
|
|
|
14
|
6
|
|
|
6
|
|
35
|
use base qw( Exporter ); |
|
6
|
|
|
|
|
10
|
|
|
6
|
|
|
|
|
4652
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
our @EXPORT_OK = qw( track leakstate status leakguard ); |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our %OPTIONS = ( |
19
|
|
|
|
|
|
|
at_end => 0, |
20
|
|
|
|
|
|
|
stderr => 0 |
21
|
|
|
|
|
|
|
); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our ( %DESTROY_NEXT, %DESTROY_ORIGINAL, %DESTROY_STUBBED, %OBJECT_COUNT, |
24
|
|
|
|
|
|
|
%TRACKED ); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
=head1 NAME |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
Devel::LeakGuard::Object - Scoped checks for object leaks |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
=head1 VERSION |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
This document describes Devel::LeakGuard::Object version 0.06 |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
=cut |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our $VERSION = '0.06'; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
=head1 SYNOPSIS |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# Track a single object |
41
|
|
|
|
|
|
|
use Devel::LeakGuard::Object; |
42
|
|
|
|
|
|
|
my $obj = Foo::Bar->new; |
43
|
|
|
|
|
|
|
Devel::LeakGuard::Object::track($obj); |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
# Track every object |
46
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( GLOBAL_bless ); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# Track every object, summary at exit |
49
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( GLOBAL_bless :at_end ); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# Track a block of code, warning on leaks |
52
|
|
|
|
|
|
|
leakguard { |
53
|
|
|
|
|
|
|
# your potentially leaky code here |
54
|
|
|
|
|
|
|
}; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# Track a block of code, die on leaks |
57
|
|
|
|
|
|
|
leakguard { |
58
|
|
|
|
|
|
|
# your potentially leaky code here |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
on_leak => 'die'; |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
=head1 DESCRIPTION |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
This module provides tracking of objects, for the purpose of |
65
|
|
|
|
|
|
|
detecting memory leaks due to circular references or innappropriate |
66
|
|
|
|
|
|
|
caching schemes. |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
It is derived from, and backwards compatible with Adam Kennedy's |
69
|
|
|
|
|
|
|
L. Any errors are mine. |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
It works by overridding C and adding a synthetic C |
72
|
|
|
|
|
|
|
method to any tracked classes so that it can maintain a count of blessed |
73
|
|
|
|
|
|
|
objects per-class. |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Object tracking can be enabled: |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
=over |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=item * for an individual object |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=item * for a block of code |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item * globally |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
=back |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=head2 Tracking an individual object |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Track individual objects like this: |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( track ); |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
# Later... |
94
|
|
|
|
|
|
|
track( my $obj = new Foo ); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=head2 Tracking object leaks in a block of code |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
To detect any object leaks in a block of code: |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( leakguard ); |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
leakguard { |
103
|
|
|
|
|
|
|
# your code here. |
104
|
|
|
|
|
|
|
}; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
=head2 Tracking global object leaks |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( GLOBAL_bless ); |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
=head2 Finding out what leaked |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
If you use C (recommended) then by default a warning is |
113
|
|
|
|
|
|
|
thrown when leaks are detected. You can customise this behaviour by |
114
|
|
|
|
|
|
|
passing options to C; see the documentation for L |
115
|
|
|
|
|
|
|
for more information. |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
If you use C or C |
118
|
|
|
|
|
|
|
C<:at_end> option |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( GLOBAL_bless :at_end ); |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
in which case a summary of leaks will be displayed at program exit. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=head2 Load early! |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
C can only track allocations of objects |
127
|
|
|
|
|
|
|
compiled after it is loaded - so load it as early as possible. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=head2 What is a leak? |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
This module counts the number of blessed instances of each tracked |
132
|
|
|
|
|
|
|
class. When we talk about a 'leak' what we really mean here is an |
133
|
|
|
|
|
|
|
imbalance in the number of allocated objects across some boundary. Using |
134
|
|
|
|
|
|
|
this definition we see a leak even in the case of expected imbalances. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
When interpreting the results you need to remember that it may be quite |
137
|
|
|
|
|
|
|
legitimate for certain allocations to live beyond the scope of the code |
138
|
|
|
|
|
|
|
under test. |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
You can use the various options that C supports to filter |
141
|
|
|
|
|
|
|
out such legitimate allocations that live beyond the life of the block |
142
|
|
|
|
|
|
|
being checked. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=head2 Performance |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
As soon as C is loaded C is overloaded. |
147
|
|
|
|
|
|
|
That means that C gets a little slower everywhere. When not |
148
|
|
|
|
|
|
|
actually tracking the overloaded C is quite fast - but still |
149
|
|
|
|
|
|
|
around four times slower than the built-in C. |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Bear in mind that C is fast and unless your program is doing a |
152
|
|
|
|
|
|
|
huge amount of blessing you're unlikely to notice a difference. On my |
153
|
|
|
|
|
|
|
machine core bless takes around 0.5 μS and loading |
154
|
|
|
|
|
|
|
C slows that down to around 2 μS. |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=head1 INTERFACE |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=cut |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
{ |
161
|
|
|
|
|
|
|
my $magic = 0; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
my $plain_bless = sub { |
164
|
42
|
|
|
42
|
|
134612
|
my $ref = shift; |
165
|
42
|
100
|
|
|
|
141
|
my $class = @_ ? shift : scalar caller; |
166
|
42
|
|
|
|
|
442
|
return CORE::bless( $ref, $class ); |
167
|
|
|
|
|
|
|
}; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
my $magic_bless = sub { |
170
|
7
|
|
|
7
|
|
24018
|
my $ref = shift; |
171
|
7
|
100
|
|
|
|
22
|
my $class = @_ ? shift : scalar caller; |
172
|
7
|
|
|
|
|
27
|
my $object = CORE::bless( $ref, $class ); |
173
|
7
|
50
|
|
|
|
100
|
unless ( $class->isa( 'Devel::LeakGuard::Object::State' ) ) { |
174
|
7
|
|
|
|
|
19
|
Devel::LeakGuard::Object::track( $object ); |
175
|
|
|
|
|
|
|
} |
176
|
7
|
|
|
|
|
70
|
return $object; |
177
|
|
|
|
|
|
|
}; |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub import { |
180
|
8
|
|
|
8
|
|
128
|
my $class = shift; |
181
|
8
|
|
|
|
|
20
|
my @args = @_; |
182
|
8
|
|
|
|
|
16
|
my @import = (); |
183
|
|
|
|
|
|
|
|
184
|
8
|
50
|
|
|
|
62
|
unless ( *CORE::GLOBAL::bless eq $plain_bless ) { |
185
|
|
|
|
|
|
|
# We don't actually need to install our version of bless here but |
186
|
|
|
|
|
|
|
# it'd be nice if any problems that it caused showed up sooner |
187
|
|
|
|
|
|
|
# rather than later. |
188
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
189
|
0
|
|
|
0
|
|
0
|
warn "It looks as if something else is already " |
190
|
|
|
|
|
|
|
. "overloading bless; there may be troubles ahead"; |
191
|
8
|
|
|
|
|
52
|
}; |
192
|
8
|
|
|
|
|
51
|
*CORE::GLOBAL::bless = $plain_bless; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
8
|
|
|
|
|
25
|
for my $a ( @args ) { |
196
|
2
|
100
|
|
|
|
11
|
if ( 'GLOBAL_bless' eq $a ) { |
|
|
50
|
|
|
|
|
|
197
|
1
|
|
|
|
|
3
|
_adj_magic( 1 ); |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
elsif ( $a =~ /^:(.+)$/ ) { |
200
|
0
|
0
|
|
|
|
0
|
croak "Bad option: $1" unless exists $OPTIONS{$1}; |
201
|
0
|
|
|
|
|
0
|
$OPTIONS{$1}++; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
else { |
204
|
1
|
|
|
|
|
4
|
push @import, $a; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
8
|
|
|
|
|
3261
|
return __PACKAGE__->export_to_level( 1, $class, @import ); |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub _adj_magic { |
212
|
43
|
|
|
43
|
|
60
|
my $adj = shift; |
213
|
43
|
|
|
|
|
51
|
my $old_magic = $magic; |
214
|
43
|
50
|
|
|
|
95
|
$magic = 0 if ( $magic += $adj ) < 0; |
215
|
|
|
|
|
|
|
{ |
216
|
6
|
|
|
6
|
|
35
|
no warnings 'redefine'; |
|
6
|
|
|
|
|
15
|
|
|
6
|
|
|
|
|
892
|
|
|
43
|
|
|
|
|
55
|
|
217
|
43
|
100
|
66
|
|
|
254
|
if ( $old_magic > 0 && $magic == 0 ) { |
|
|
50
|
33
|
|
|
|
|
218
|
21
|
|
|
|
|
72
|
*CORE::GLOBAL::bless = $plain_bless; |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
elsif ( $old_magic == 0 && $magic > 0 ) { |
221
|
22
|
|
|
|
|
101
|
*CORE::GLOBAL::bless = $magic_bless; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
=head2 C<< leakguard >> |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
Run a block of code tracking object creation and destruction and report |
230
|
|
|
|
|
|
|
any leaks at block exit. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
At its simplest C runs a block of code and warns if leaks |
233
|
|
|
|
|
|
|
are found: |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
leakguard { |
236
|
|
|
|
|
|
|
my $foo = Foo->new; |
237
|
|
|
|
|
|
|
$foo->{me} = $foo; # leak |
238
|
|
|
|
|
|
|
}; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
# Displays this warning: |
241
|
|
|
|
|
|
|
Object leaks found: |
242
|
|
|
|
|
|
|
Class Before After Delta |
243
|
|
|
|
|
|
|
Foo 3 4 1 |
244
|
|
|
|
|
|
|
Detected at foo.pl line 23 |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
If you really don't want to leak you can die instead of warning: |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
leakguard { |
249
|
|
|
|
|
|
|
my $foo = Foo->new; |
250
|
|
|
|
|
|
|
$foo->{me} = $foo; # leak |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
on_leak => 'die'; |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
If you need to do something more complex you can pass a coderef to the |
255
|
|
|
|
|
|
|
C option: |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
leakguard { |
258
|
|
|
|
|
|
|
my $foo = Foo->new; |
259
|
|
|
|
|
|
|
$foo->{me} = $foo; # leak |
260
|
|
|
|
|
|
|
my $bar = Bar->new; |
261
|
|
|
|
|
|
|
$bar->{me} = $bar; # leak again |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
on_leak => sub { |
264
|
|
|
|
|
|
|
my $report = shift; |
265
|
|
|
|
|
|
|
for my $pkg ( sort keys %$report ) { |
266
|
|
|
|
|
|
|
printf "%s %d %d\n", $pkg, @{ $report->{$pkg} }; |
267
|
|
|
|
|
|
|
} |
268
|
|
|
|
|
|
|
# do something |
269
|
|
|
|
|
|
|
}; |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
In the event of a leak the sub will be called with a reference to a |
272
|
|
|
|
|
|
|
hash. The keys of the hash are the names of classes that have leaked; |
273
|
|
|
|
|
|
|
the values are refs to two-element arrays containing the bless count for |
274
|
|
|
|
|
|
|
that class before and after the block so the example above would print: |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
Foo 0 1 |
277
|
|
|
|
|
|
|
Bar 0 1 |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=head3 Options |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Other options are supported. Here's the full list: |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=over |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=item C |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
What to do if a leak is detected. May be 'warn' (the default), 'die', |
288
|
|
|
|
|
|
|
'ignore' or a code reference. If C is set to 'ignore' no leak |
289
|
|
|
|
|
|
|
tracking will be performed. |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=item C |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
If you need to concentrate on a subset of classes use C to limit |
294
|
|
|
|
|
|
|
leak tracking to a subset of classes: |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
leakguard { |
297
|
|
|
|
|
|
|
# do stuff |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
only => 'My::Stuff::*'; |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
The pattern to match can be a string (with '*' as a shell-style |
302
|
|
|
|
|
|
|
wildcard), a C, a coderef or a reference to an array of any of |
303
|
|
|
|
|
|
|
the above. This (improbable) example illustrates all of these: |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
leakguard { |
306
|
|
|
|
|
|
|
# do stuff |
307
|
|
|
|
|
|
|
} |
308
|
|
|
|
|
|
|
only => [ |
309
|
|
|
|
|
|
|
'My::Stuff::*', |
310
|
|
|
|
|
|
|
qr{Leaky}, |
311
|
|
|
|
|
|
|
sub { length $_ > 20 } |
312
|
|
|
|
|
|
|
]; |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
That would track classes beginning with 'My::Stuff::', containing |
315
|
|
|
|
|
|
|
'Leaky' or whose length is greater than 20 characters. |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
=item C |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
To track all classes apart from a few exceptions use C. The |
320
|
|
|
|
|
|
|
C spec is like an C spec but classes that match will be |
321
|
|
|
|
|
|
|
excluded from tracking. |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
=item C |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
Sometimes a certain amount of 'leakage' is acceptable. Imagine, for |
326
|
|
|
|
|
|
|
example, an application that maintains a single cached database |
327
|
|
|
|
|
|
|
connection in a class called C. The connection is created on |
328
|
|
|
|
|
|
|
demand and deleted after it has been used 100 times - to be created |
329
|
|
|
|
|
|
|
again next time it's needed. |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
We could use C to ignore this class - but then we'd miss the |
332
|
|
|
|
|
|
|
case where something goes wrong and we create 5 connections at a time. |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
Using C we can specify that no more than one C should |
335
|
|
|
|
|
|
|
be created or destroyed: |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
leakguard { |
338
|
|
|
|
|
|
|
# do stuff |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
expect => { |
341
|
|
|
|
|
|
|
'My::DB' => [ -1, 1 ] |
342
|
|
|
|
|
|
|
}; |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
=back |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
=cut |
347
|
|
|
|
|
|
|
|
348
|
6
|
|
|
6
|
|
17690
|
use Devel::Peek; |
|
6
|
|
|
|
|
3825
|
|
|
6
|
|
|
|
|
37
|
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
sub leakguard(&@) { |
351
|
20
|
|
|
20
|
1
|
18991
|
my $block = shift; |
352
|
20
|
|
|
|
|
117
|
my $leakstate = Devel::LeakGuard::Object::State->new( @_ ); |
353
|
20
|
|
|
|
|
167
|
$block->(); |
354
|
20
|
|
|
|
|
250
|
$leakstate->done(); |
355
|
19
|
|
|
|
|
263
|
return; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
=head2 C<< leakstate >> |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
Get the current allocation counts for all tracked objects. If |
361
|
|
|
|
|
|
|
C is in force this will include all blessed objects. If |
362
|
|
|
|
|
|
|
you are using the finer-grained tracking tools (L and |
363
|
|
|
|
|
|
|
L) then only allocations that they cover will be included. |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
Returns a reference to a hash with package names as keys and allocation |
366
|
|
|
|
|
|
|
counts as values. |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
=cut |
369
|
|
|
|
|
|
|
|
370
|
42
|
|
|
42
|
1
|
201
|
sub leakstate { return {%OBJECT_COUNT} } |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=head2 C<< track >> |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
Track an individual object. Tracking an object increases the allocation |
375
|
|
|
|
|
|
|
count for its package by one. When the object is destroyed the |
376
|
|
|
|
|
|
|
allocation count is decreased by one. Current allocation counts may be |
377
|
|
|
|
|
|
|
retrieved using L. |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
If the object is reblessed into a different package the count for the |
380
|
|
|
|
|
|
|
new package will be incremented and the count for the old package |
381
|
|
|
|
|
|
|
decremented. |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=cut |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
sub track { |
386
|
73
|
|
|
73
|
1
|
6051
|
my $object = shift; |
387
|
73
|
|
|
|
|
217
|
my $class = blessed $object; |
388
|
|
|
|
|
|
|
|
389
|
73
|
50
|
|
|
|
174
|
carp "Devel::LeakGuard::Object::track was passed a non-object" |
390
|
|
|
|
|
|
|
unless defined $class; |
391
|
|
|
|
|
|
|
|
392
|
73
|
|
|
|
|
179
|
my $address = refaddr $object; |
393
|
73
|
100
|
|
|
|
206
|
if ( $TRACKED{$address} ) { |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# Reblessing into the same class, ignore |
396
|
1
|
50
|
|
|
|
4
|
return $OBJECT_COUNT{$class} |
397
|
|
|
|
|
|
|
if $class eq $TRACKED{$address}; |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# Reblessing into a different class |
400
|
1
|
|
|
|
|
3
|
$OBJECT_COUNT{ $TRACKED{$address} }--; |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
73
|
|
|
|
|
188
|
$TRACKED{$address} = $class; |
404
|
|
|
|
|
|
|
|
405
|
73
|
100
|
|
|
|
199
|
unless ( $DESTROY_STUBBED{$class} ) { |
406
|
6
|
|
|
6
|
|
2708
|
no strict 'refs'; |
|
6
|
|
|
|
|
23
|
|
|
6
|
|
|
|
|
199
|
|
407
|
6
|
|
|
6
|
|
46
|
no warnings 'redefine'; |
|
6
|
|
|
|
|
9
|
|
|
6
|
|
|
|
|
3388
|
|
408
|
|
|
|
|
|
|
|
409
|
16
|
50
|
100
|
|
|
22
|
if ( exists ${ $class . '::' }{DESTROY} |
|
16
|
|
|
|
|
101
|
|
|
1
|
|
|
|
|
8
|
|
410
|
|
|
|
|
|
|
and *{ $class . '::DESTROY' }{CODE} ) { |
411
|
0
|
|
|
|
|
0
|
$DESTROY_ORIGINAL{$class} = \&{ $class . '::DESTROY' }; |
|
0
|
|
|
|
|
0
|
|
412
|
|
|
|
|
|
|
} |
413
|
|
|
|
|
|
|
|
414
|
16
|
|
|
|
|
39
|
$DESTROY_STUBBED{$class} = 1; |
415
|
|
|
|
|
|
|
|
416
|
16
|
|
|
|
|
50
|
*{"${class}::DESTROY"} = _mk_destroy( $class ); |
|
16
|
|
|
|
|
97
|
|
417
|
|
|
|
|
|
|
|
418
|
16
|
|
|
|
|
64
|
_mk_next( $class ); |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
73
|
|
|
|
|
190
|
$OBJECT_COUNT{ $TRACKED{$address} }++; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
sub _mk_destroy { |
425
|
16
|
|
|
16
|
|
36
|
my $pkg = shift; |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
return sub { |
428
|
22
|
|
|
22
|
|
9346
|
my $self = $_[0]; |
429
|
22
|
|
|
|
|
73
|
my $class = blessed $self; |
430
|
22
|
|
|
|
|
56
|
my $address = refaddr $self; |
431
|
|
|
|
|
|
|
|
432
|
22
|
50
|
|
|
|
67
|
die "Unexpected error: First param to DESTROY is no an object" |
433
|
|
|
|
|
|
|
unless defined $class; |
434
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
# Don't do anything unless tracking for the specific object is set |
436
|
22
|
|
|
|
|
52
|
my $original = $TRACKED{$address}; |
437
|
22
|
100
|
|
|
|
45
|
if ( $original ) { |
438
|
|
|
|
|
|
|
|
439
|
12
|
50
|
|
|
|
35
|
warn "Object class '$class' does", |
440
|
|
|
|
|
|
|
" not match original $TRACKED{$address}" |
441
|
|
|
|
|
|
|
if $class ne $original; |
442
|
|
|
|
|
|
|
|
443
|
12
|
|
|
|
|
24
|
$OBJECT_COUNT{$original}--; |
444
|
|
|
|
|
|
|
|
445
|
12
|
50
|
|
|
|
35
|
warn "Object count for $TRACKED{$address}", |
446
|
|
|
|
|
|
|
" negative ($OBJECT_COUNT{$original})" |
447
|
|
|
|
|
|
|
if $OBJECT_COUNT{$original} < 0; |
448
|
|
|
|
|
|
|
|
449
|
12
|
|
|
|
|
30
|
delete $TRACKED{$address}; |
450
|
|
|
|
|
|
|
|
451
|
12
|
50
|
|
|
|
52
|
goto &{ $DESTROY_ORIGINAL{$original} } |
|
0
|
|
|
|
|
0
|
|
452
|
|
|
|
|
|
|
if $DESTROY_ORIGINAL{$original}; |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
else { |
455
|
10
|
|
|
|
|
16
|
$original = $class; |
456
|
|
|
|
|
|
|
} |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
# If we don't have the DESTROY_NEXT for this class, populate it |
459
|
22
|
|
|
|
|
47
|
_mk_next( $original ); |
460
|
22
|
|
|
|
|
45
|
my $super = $DESTROY_NEXT{$original}{$pkg}; |
461
|
22
|
100
|
|
|
|
51
|
goto &{"${super}::DESTROY"} if $super; |
|
5
|
|
|
|
|
31
|
|
462
|
17
|
|
|
|
|
194
|
return; |
463
|
16
|
|
|
|
|
106
|
}; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
sub _mk_next { |
467
|
38
|
|
|
38
|
|
58
|
my $class = shift; |
468
|
|
|
|
|
|
|
|
469
|
6
|
|
|
6
|
|
34
|
no strict 'refs'; |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
2734
|
|
470
|
38
|
100
|
|
|
|
248
|
return if $DESTROY_NEXT{$class}; |
471
|
|
|
|
|
|
|
|
472
|
18
|
|
|
|
|
45
|
$DESTROY_NEXT{$class} = {}; |
473
|
|
|
|
|
|
|
|
474
|
18
|
|
|
|
|
45
|
my @stack = ( $class ); |
475
|
18
|
|
|
|
|
47
|
my %seen = ( UNIVERSAL => 1 ); |
476
|
18
|
|
|
|
|
34
|
my @queue = (); |
477
|
|
|
|
|
|
|
|
478
|
18
|
|
|
|
|
58
|
while ( my $c = pop @stack ) { |
479
|
31
|
50
|
|
|
|
98
|
next if $seen{$c}++; |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
my $has_destroy |
482
|
|
|
|
|
|
|
= $DESTROY_STUBBED{$c} |
483
|
|
|
|
|
|
|
? exists $DESTROY_ORIGINAL{$c} |
484
|
31
|
100
|
100
|
|
|
258
|
: ( exists ${"${c}::"}{DESTROY} and *{"${c}::DESTROY"}{CODE} ); |
485
|
|
|
|
|
|
|
|
486
|
31
|
100
|
|
|
|
66
|
if ( $has_destroy ) { |
487
|
2
|
|
|
|
|
13
|
$DESTROY_NEXT{$class}{$_} = $c for @queue; |
488
|
2
|
|
|
|
|
4
|
@queue = (); |
489
|
|
|
|
|
|
|
} |
490
|
|
|
|
|
|
|
else { |
491
|
29
|
|
|
|
|
55
|
push @queue, $c; |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
31
|
|
|
|
|
56
|
push @stack, reverse @{"${c}::ISA"}; |
|
31
|
|
|
|
|
177
|
|
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
18
|
|
|
|
|
204
|
$DESTROY_NEXT{$class}{$_} = '' for @queue; |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
=head2 C |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
Print out a L style summary of current object |
503
|
|
|
|
|
|
|
allocations. If you |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
use Devel::LeakGuard::Object qw( GLOBAL_bless :at_end ); |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
then C will be called at program exit to dump a summary of |
508
|
|
|
|
|
|
|
outstanding allocations. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=cut |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
sub status { |
513
|
0
|
0
|
|
0
|
1
|
0
|
my $fh = $OPTIONS{stderr} ? *STDERR : *STDOUT; |
514
|
0
|
|
|
|
|
0
|
print $fh "Tracked objects by class:\n"; |
515
|
0
|
|
|
|
|
0
|
for ( sort keys %OBJECT_COUNT ) { |
516
|
0
|
0
|
|
|
|
0
|
next unless $OBJECT_COUNT{$_}; # Don't list class with count zero |
517
|
0
|
|
|
|
|
0
|
print $fh sprintf "%-40s %d\n", $_, $OBJECT_COUNT{$_}; |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
6
|
50
|
|
6
|
|
3886
|
END { status() if $OPTIONS{at_end} } |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
1; |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
__END__ |