File Coverage

blib/lib/Test2/Tools/Refcount.pm
Criterion Covered Total %
statement 43 43 100.0
branch 4 4 100.0
condition n/a
subroutine 10 10 100.0
pod 3 3 100.0
total 60 60 100.0


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-2023 -- leonerd@leonerd.org.uk
5              
6             package Test2::Tools::Refcount;
7              
8 158     158   4661 use strict;
  158         387  
  158         4523  
9 158     158   776 use warnings;
  158         326  
  158         4245  
10              
11 158     158   810 use Test2::API qw(context release);
  158         331  
  158         8417  
12              
13 158     158   993 use Scalar::Util qw( weaken refaddr );
  158         367  
  158         7592  
14 158     158   1021 use B qw( svref_2object );
  158         370  
  158         14700  
15              
16             our $VERSION = '0.000153';
17              
18             our @EXPORT = qw(
19             is_refcount
20             is_oneref
21             );
22              
23             our @EXPORT_OK = qw(
24             refcount
25             );
26              
27 158     158   1238 use base qw(Exporter);
  158         449  
  158         22813  
28              
29 158         397 use constant HAVE_DEVEL_MAT_DUMPER => defined eval {
30             package # No Index
31             Devel::MAT::Dumper;
32 158         326 our $HELPER_PER_PACKAGE;
33 158         320 our $HELPER_PER_MAGIC;
34 158         96182 require Devel::MAT::Dumper;
35 158     158   1221 };
  158         349  
36              
37             =encoding UTF-8
38              
39             =head1 NAME
40              
41             C - assert reference counts on objects
42              
43             =head1 SYNOPSIS
44              
45             use Test2::Tools::Refcount;
46              
47             use Some::Class;
48             my $object = Some::Class->new();
49              
50             is_oneref( $object, '$object has a refcount of 1' );
51              
52             my $otherref = $object;
53              
54             is_refcount( $object, 2, '$object now has 2 references' );
55              
56             =head1 DESCRIPTION
57              
58             The Perl garbage collector uses simple reference counting during the normal
59             execution of a program. This means that cycles or unweakened references in
60             other parts of code can keep an object around for longer than intended. To
61             help avoid this problem, the reference count of a new object from its class
62             constructor ought to be 1. This way, the caller can know the object will be
63             properly DESTROYed when it drops all of its references to it.
64              
65             This module provides two test functions to help ensure this property holds
66             for an object class, so as to be polite to its callers.
67              
68             If the assertion fails; that is, if the actual reference count is different to
69             what was expected, either of the following two modules may be used to assist
70             the developer in finding where the references are.
71              
72             =over 4
73              
74             =item *
75              
76             If L is installed, this test module will use it to dump the state
77             of the memory after a failure. It will create a F<.pmat> file named the same
78             as the unit test, but with the trailing F<.t> suffix replaced with
79             F<-TEST.pmat> where C is the number of the test that failed (in case
80             there was more than one).
81              
82             =back
83              
84             See the examples below for more information.
85              
86             =cut
87              
88             =head1 FUNCTIONS
89              
90             =cut
91              
92             =head2 is_refcount
93              
94             is_refcount( $object, $count, $name )
95              
96             Test that $object has $count references to it.
97              
98             =cut
99              
100             sub is_refcount($$;$)
101             {
102 18     18 1 15282 my ( $object, $count, $name ) = @_;
103 18         38 @_ = ();
104              
105 18         50 my $ctx = context();
106              
107 18 100       1564 if( !ref $object ) {
108 1         12 my $ok = $ctx->ok( 0, $name );
109 1         546 $ctx->diag( " expected a reference, was not given one" );
110 1         193 $ctx->release;
111 1         28 return $ok;
112             }
113              
114 17         64 weaken $object; # So this reference itself doesn't show up
115              
116 17         38 my $REFCNT = refcount( $object );
117              
118 17         72 my $ok = $ctx->ok( $REFCNT == $count, $name );
119              
120 17 100       2656 unless( $ok->pass ) {
121 3         37 $ctx->diag( " expected $count references, found $REFCNT" );
122              
123 3         537 if( HAVE_DEVEL_MAT_DUMPER ) {
124             my $file = $0;
125             my $hub = $ctx->hub;
126             my $num = $hub->count;
127              
128             # Trim the .t off first then append -$num.pmat, in case $0 wasn't a .t file
129             $file =~ s/\.(?:t|pm|pl)$//;
130             $file .= "-$num\.pmat";
131             $ctx->diag( sprintf "SV address is 0x%x", refaddr $object );
132             $ctx->diag( "Writing heap dump to $file" );
133             Devel::MAT::Dumper::dump( $file );
134             }
135             }
136              
137 17         118 $ctx->release;
138 17         491 return $ok;
139             }
140              
141             =head2 is_oneref
142              
143             is_oneref( $object, $name )
144              
145             Assert that the $object has only 1 reference to it.
146              
147             =cut
148              
149             sub is_oneref($;$)
150             {
151 5     5 1 12994 splice( @_, 1, 0, ( 1 ) );
152 5         21 goto &is_refcount;
153             }
154              
155             =head2 refcount
156              
157             $count = refcount( $object )
158              
159             Returns the reference count of the given object as used by the test functions.
160             This is useful for making tests that don't care what the count is before they
161             start, but simply assert that the count hasn't changed by the end.
162              
163             use Test2::Tools::Refcount import => [qw( is_refcount refcount )];
164             {
165             my $count = refcount( $object );
166              
167             do_something( $object );
168              
169             is_refcount( $object, $count, 'do_something() preserves refcount' );
170             }
171              
172             =cut
173              
174             sub refcount
175             {
176 17     17 1 267 return svref_2object( $_[0] )->REFCNT;
177             }
178              
179             =head1 EXAMPLE
180              
181             Suppose, having written a new class C, you now want to check that its
182             constructor and methods are well-behaved, and don't leak references. Consider
183             the following test script:
184              
185             use Test::More tests => 2;
186             use Test2::Tools::Refcount;
187              
188             use MyBall;
189              
190             my $ball = MyBall->new();
191             is_oneref( $ball, 'One reference after construct' );
192              
193             $ball->bounce;
194              
195             # Any other code here that might be part of the test script
196              
197             is_oneref( $ball, 'One reference just before EOF' );
198              
199             The first assertion is just after the constructor, to check that the reference
200             returned by it is the only reference to that object. This fact is important if
201             we ever want C to behave properly. The second call is right at the
202             end of the file, just before the main scope closes. At this stage we expect
203             the reference count also to be one, so that the object is properly cleaned up.
204              
205             Suppose, when run, this produces the following output (presuming
206             L is available):
207              
208             1..2
209             ok 1 - One reference after construct
210             not ok 2 - One reference just before EOF
211             # Failed test 'One reference just before EOF'
212             # at ex.pl line 26.
213             # expected 1 references, found 2
214             # SV address is 0x55e14c310278
215             # Writing heap dump to ex-2.pmat
216             # Looks like you failed 1 test of 2.
217              
218             This has written a F file we can load using the C shell and
219             use the C command on the given address to find where it went:
220              
221             $ pmat ex-2.pmat
222             Perl memory dumpfile from perl 5.28.1 threaded
223             Heap contains 25233 objects
224             pmat> identify 0x55e14c310278
225             HASH(0)=MyBall at 0x55e14c310278 is:
226             ├─(via RV) the lexical $ball at depth 1 of CODE() at 0x55e14c3104a0=main_cv, which is:
227             │ └─the main code
228             └─(via RV) value {self} of HASH(2) at 0x55e14cacb860, which is (*A):
229             └─(via RV) value {cycle} of HASH(2) at 0x55e14cacb860, which is:
230             itself
231              
232             (This document isn't intended to be a full tutorial on L and the
233             C shell; for that see L).
234              
235             From this output, we can see that the constructor was well-behaved, but that a
236             reference was leaked by the end of the script - the reference count was 2,
237             when we expected just 1. Reading the trace output, we can see that there were
238             2 references that could be found - one stored in the $ball lexical in the main
239             program, and one stored in a HASH. Since we expected to find the $ball lexical
240             variable, we know we are now looking for a leak in a hash somewhere in the
241             code. From reading the test script, we can guess this leak is likely to be in
242             the bounce() method. Furthermore, we know that the reference to the object
243             will be stored in a HASH in a member called C.
244              
245             By reading the code which implements the bounce() method, we can see this is
246             indeed the case:
247              
248             sub bounce
249             {
250             my $self = shift;
251             my $cycle = { self => $self };
252             $cycle->{cycle} = $cycle;
253             }
254              
255             From reading the tracing output, we find that the HASH this object is
256             referenced in also contains a reference to itself, in a member called
257             C. This comes from the last line in this function, a line that
258             purposely created a cycle, to demonstrate the point. While a real program
259             probably wouldn't do anything quite this obvious, the trace would still be
260             useful in finding the likely cause of the leak.
261              
262             If C is not available, then these detailed traces will not
263             be produced. The basic reference count testing will still take place, but a
264             smaller message will be produced:
265              
266             1..2
267             ok 1 - One reference after construct
268             not ok 2 - One reference just before EOF
269             # Failed test 'One reference just before EOF'
270             # at demo.pl line 16.
271             # expected 1 references, found 2
272             # Looks like you failed 1 test of 2.
273              
274             =head1 BUGS
275              
276             =over 4
277              
278             =item * Temporaries created on the stack
279              
280             Code which creates temporaries on the stack, to be released again when the
281             called function returns does not work correctly on perl 5.8 (and probably
282             before). Examples such as
283              
284             is_oneref( [] );
285              
286             may fail and claim a reference count of 2 instead.
287              
288             Passing a variable such as
289              
290             my $array = [];
291             is_oneref( $array );
292              
293             works fine. Because of the intention of this test module; that is, to assert
294             reference counts on some object stored in a variable during the lifetime of
295             the test script, this is unlikely to cause any problems.
296              
297             =back
298              
299             =head1 ACKNOWLEDGEMENTS
300              
301             Peter Rabbitson - for suggesting using core's C
302             instead of C to obtain refcounts
303              
304             =head1 AUTHOR
305              
306             Paul Evans
307              
308             =cut
309              
310             0x55AA;