line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Devel::Refcount; |
7
|
|
|
|
|
|
|
|
8
|
6
|
|
|
6
|
|
131123
|
use strict; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
217
|
|
9
|
6
|
|
|
6
|
|
34
|
use warnings; |
|
6
|
|
|
|
|
14
|
|
|
6
|
|
|
|
|
261
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.10'; |
12
|
|
|
|
|
|
|
|
13
|
6
|
|
|
6
|
|
43
|
use Exporter 'import'; |
|
6
|
|
|
|
|
13
|
|
|
6
|
|
|
|
|
558
|
|
14
|
|
|
|
|
|
|
our @EXPORT_OK = qw( refcount assert_oneref ); |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
require XSLoader; |
17
|
|
|
|
|
|
|
if( !eval { XSLoader::load( __PACKAGE__, $VERSION ) } ) { |
18
|
|
|
|
|
|
|
*refcount = \&_refcount_pp; |
19
|
|
|
|
|
|
|
require B; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
|
22
|
6
|
|
|
6
|
|
39
|
use Carp; |
|
6
|
|
|
|
|
16
|
|
|
6
|
|
|
|
|
527
|
|
23
|
6
|
|
|
6
|
|
121
|
use Scalar::Util qw( weaken ); |
|
6
|
|
|
|
|
12
|
|
|
6
|
|
|
|
|
4017
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
=head1 NAME |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
C - obtain the REFCNT value of a referent |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
=head1 SYNOPSIS |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
use Devel::Refcount qw( refcount ); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $anon = []; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
print "Anon ARRAY $anon has " . refcount( $anon ) . " reference\n"; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $otherref = $anon; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
print "Anon ARRAY $anon now has " . refcount( $anon ) . " references\n"; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
assert_oneref $otherref; # This will throw an exception at runtime |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 DESCRIPTION |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
This module provides a single function which obtains the reference count of |
46
|
|
|
|
|
|
|
the object being pointed to by the passed reference value. It also provides a |
47
|
|
|
|
|
|
|
debugging assertion that asserts a given reference has a count of only 1. |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
=cut |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 FUNCTIONS |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
=cut |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
=head2 $count = refcount( $ref ) |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
Returns the reference count of the object being pointed to by $ref. |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
=cut |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# This normally isn't used if the XS code is loaded |
62
|
|
|
|
|
|
|
sub _refcount_pp |
63
|
|
|
|
|
|
|
{ |
64
|
12
|
|
|
12
|
|
203
|
B::svref_2object( shift )->REFCNT; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head2 assert_oneref( $ref ) |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
Asserts that the given object reference has a reference count of only 1. If |
70
|
|
|
|
|
|
|
this is true the function does nothing. If it has more than 1 reference then |
71
|
|
|
|
|
|
|
an exception is thrown. Additionally, if L is available, it |
72
|
|
|
|
|
|
|
will be used to print a more detailed trace of where the references are found. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Typically this would be useful in debugging to track down cases where objects |
75
|
|
|
|
|
|
|
are still being referenced beyond the point at which they are supposed to be |
76
|
|
|
|
|
|
|
dropped. For example, if an element is delete from a hash that ought to be the |
77
|
|
|
|
|
|
|
last remaining reference, the return value of the C operator can be |
78
|
|
|
|
|
|
|
asserted on |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
assert_oneref delete $self->{some_item}; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
If at the time of deleting there are any other references to this object then |
83
|
|
|
|
|
|
|
the assertion will fail; and if C is available the other |
84
|
|
|
|
|
|
|
locations will be printed. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=cut |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub assert_oneref |
89
|
|
|
|
|
|
|
{ |
90
|
3
|
|
|
3
|
1
|
1669
|
my $object = shift; |
91
|
3
|
|
|
|
|
11
|
weaken $object; |
92
|
|
|
|
|
|
|
|
93
|
3
|
|
|
|
|
9
|
my $refcount = refcount( $object ); |
94
|
3
|
100
|
|
|
|
12
|
return if $refcount == 1; |
95
|
|
|
|
|
|
|
|
96
|
1
|
|
|
|
|
193
|
my $message = Carp::shortmess( "Expected $object to have only one reference, found $refcount" ); |
97
|
|
|
|
|
|
|
|
98
|
1
|
50
|
|
|
|
33
|
if( eval { require Devel::FindRef } ) { |
|
1
|
|
|
|
|
514
|
|
99
|
0
|
|
|
|
|
0
|
my $track = Devel::FindRef::track( $object ); |
100
|
0
|
|
|
|
|
0
|
die "$message\n$track\n"; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
else { |
103
|
1
|
|
|
|
|
8
|
die $message; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
=head1 COMPARISON WITH SvREFCNT |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
This function differs from C in that SvREFCNT() gives |
110
|
|
|
|
|
|
|
the reference count of the SV object itself that it is passed, whereas |
111
|
|
|
|
|
|
|
refcount() gives the count of the object being pointed to. This allows it to |
112
|
|
|
|
|
|
|
give the count of any referent (i.e. ARRAY, HASH, CODE, GLOB and Regexp types) |
113
|
|
|
|
|
|
|
as well. |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
Consider the following example program: |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
use Devel::Peek qw( SvREFCNT ); |
118
|
|
|
|
|
|
|
use Devel::Refcount qw( refcount ); |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub printcount |
121
|
|
|
|
|
|
|
{ |
122
|
|
|
|
|
|
|
my $name = shift; |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
printf "%30s has SvREFCNT=%d, refcount=%d\n", |
125
|
|
|
|
|
|
|
$name, SvREFCNT( $_[0] ), refcount( $_[0] ); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
my $var = []; |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
printcount 'Initially, $var', $var; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
my $othervar = $var; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
printcount 'Before CODE ref, $var', $var; |
135
|
|
|
|
|
|
|
printcount '$othervar', $othervar; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
my $code = sub { undef $var }; |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
printcount 'After CODE ref, $var', $var; |
140
|
|
|
|
|
|
|
printcount '$othervar', $othervar; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
This produces the output |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
Initially, $var has SvREFCNT=1, refcount=1 |
145
|
|
|
|
|
|
|
Before CODE ref, $var has SvREFCNT=1, refcount=2 |
146
|
|
|
|
|
|
|
$othervar has SvREFCNT=1, refcount=2 |
147
|
|
|
|
|
|
|
After CODE ref, $var has SvREFCNT=2, refcount=2 |
148
|
|
|
|
|
|
|
$othervar has SvREFCNT=1, refcount=2 |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
Here, we see that SvREFCNT() counts the number of references to the SV object |
151
|
|
|
|
|
|
|
passed in as the scalar value - the $var or $othervar respectively, whereas |
152
|
|
|
|
|
|
|
refcount() counts the number of reference values that point to the referent |
153
|
|
|
|
|
|
|
object - the anonymous ARRAY in this case. |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
Before the CODE reference is constructed, both $var and $othervar have |
156
|
|
|
|
|
|
|
SvREFCNT() of 1, as they exist only in the current lexical pad. The anonymous |
157
|
|
|
|
|
|
|
ARRAY has a refcount() of 2, because both $var and $othervar store a reference |
158
|
|
|
|
|
|
|
to it. |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
After the CODE reference is constructed, the $var variable now has an |
161
|
|
|
|
|
|
|
SvREFCNT() of 2, because it also appears in the lexical pad for the new |
162
|
|
|
|
|
|
|
anonymous CODE block. |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
=cut |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=head1 PURE-PERL FALLBACK |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
An XS implementation of this function is provided, and is used by default. If |
169
|
|
|
|
|
|
|
the XS library cannot be loaded, a fallback implementation in pure perl using |
170
|
|
|
|
|
|
|
the C module is used instead. This will behave identically, but is much |
171
|
|
|
|
|
|
|
slower. |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
Rate pp xs |
174
|
|
|
|
|
|
|
pp 225985/s -- -66% |
175
|
|
|
|
|
|
|
xs 669570/s 196% -- |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
=head1 SEE ALSO |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
=over 4 |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
=item * |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
L - assert reference counts on objects |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=back |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
=head1 AUTHOR |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
Paul Evans |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
=cut |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
0x55AA; |