File Coverage

blib/lib/Test/NoLeaks.pm
Criterion Covered Total %
statement 86 97 88.6
branch 24 44 54.5
condition 21 35 60.0
subroutine 13 13 100.0
pod 2 2 100.0
total 146 191 76.4


line stmt bran cond sub pod time code
1             package Test::NoLeaks;
2              
3 5     5   104606 use strict;
  5         7  
  5         115  
4 5     5   15 use warnings;
  5         6  
  5         120  
5 5     5   1606 use POSIX qw/sysconf _SC_PAGESIZE/;
  5         19065  
  5         22  
6 5     5   3164 use Test::Builder;
  5         5  
  5         69  
7 5     5   14 use Test::More;
  5         3  
  5         19  
8              
9             our $VERSION = '0.05';
10              
11 5     5   886 use base qw(Exporter);
  5         6  
  5         674  
12              
13             our @EXPORT = qw/test_noleaks/;
14             our @EXPORT_OK = qw/noleaks/;
15              
16              
17             =head1 NAME
18              
19             Test::NoLeaks - Memory and file descriptor leak detector
20              
21             =head1 VERSION
22              
23             0.05
24              
25             =head1 SYNOPSYS
26              
27             use Test::NoLeaks;
28              
29             test_noleaks (
30             code => sub{
31             # code that might leak
32             },
33             track_memory => 1,
34             track_fds => 1,
35             passes => 2,
36             warmup_passes => 1,
37             tolerate_hits => 0,
38             );
39              
40             Sample output:
41             # pass 1, leaked: 225280 bytes 0 file descriptors
42             # pass 36, leaked: 135168 bytes 0 file descriptors
43             # pass 52, leaked: 319488 bytes 0 file descriptors
44             # pass 84, leaked: 135168 bytes 0 file descriptors
45             # pass 98, leaked: 155648 bytes 0 file descriptors
46             not ok 1214 - Leaked 970752 bytes (5 hits) 0 file descriptors
47              
48             test_noleaks (
49             code => sub { ... },
50             track_memory => 1,
51             passes => 2,
52             );
53              
54             # old-school way
55             use Test::More;
56             use Test::NoLeaks qw/noleaks/;
57             ok noleaks(
58             code => sub { ... },
59             track_memory => ...,
60             track_fds => ...,
61             passes => ...,
62             warmup_passes => ...,
63             ), "non-leaked code description";
64              
65             =head1 DESCRIPTION
66              
67             It is hard to track memory leaks. There are a lot of perl modules (e.g.
68             L), that try to B and B leaks. Unfortunately,
69             they do not always work, and they are rather limited because they are not
70             able to detect leaks in XS-code or external libraries.
71              
72             Instead of examining perl internals, this module offers a bit naive empirical
73             approach: let the suspicious code to be launched in infinite loop
74             some time and watch (via tools like C)if the memory consumption by
75             perl process increses over time. If it does, while it is expected to
76             be constant (stabilized), then, surely, there are leaks.
77              
78             This approach is able only to B and not able to B them. The
79             module C implements the general idea of the approach, which
80             might be enough in many cases.
81              
82             =head1 INTERFACE
83              
84             =head3 C<< test_noleaks >>
85              
86             =head3 C<< noleaks >>
87              
88             The mandatory hash has the following members
89              
90             =over 2
91              
92             =item * C
93              
94             Suspicious for leaks subroutine, that will be executed multiple times.
95              
96             =item * C
97              
98             =item * C
99              
100             Track memory or file descriptor leaks. At leas one of them should be
101             specified.
102              
103             In B, every socket is file descriptor too, so, C
104             will be able to track unclosed sockets, i.e. network connections.
105              
106             =item * C
107              
108             How many times C should be executed. If memory leak is too small,
109             number of passes should be large enough to trigger additional pages
110             allocation for perl process, and the leak will be detected.
111              
112             Page size is 4kb on linux, so, if C leaks 4 bytes on every
113             pass, then C<1024> passes should be specified.
114              
115             In general, the more passes are specified, the more chance to
116             detect possible leaks.
117              
118             It is good idea to initally define C to some large number,
119             e.g. C<10_000> to be sure, that the suspicious code leaks, but then
120             decrease to some smaller number, enough to produce test fail report,
121             i.e. enough to produces 3-5 memory hits (additional pages allocations).
122             This will speed up tests execution and will save CO2 atmospheric
123             emissions a little bit.
124              
125             Default value is C<100>. Minimal value is C<2>.
126              
127             =item * C
128              
129             How many times the C should be executed before module starts
130             tracking resources consumption on executing the C C
131             times.
132              
133             If you have caches, memoizes etc., then C is your
134             friend.
135              
136             Default value is C<0>.
137              
138             =item * C
139              
140             How many passes, which considered leaked, should be ingnored, i.e.
141             maximal number of possible false leak reports.
142              
143             Even if your code has no leaks, it might cause perl interpreter
144             allocate additional memory pages, e.g. due to memory fragmentation.
145             Those allocations are legal, and should not be treated as leaks.
146              
147             Use this B when memory leaks are already fixed, but there
148             are still false leak reports from C. This value expected
149             to be small enough, i.e. C<1> or C<2>. For additional assurance, please,
150             increase C value, if C is non-zero.
151              
152             Default value is C<0>.
153              
154             =back
155              
156             =head1 MEMORY LEAKS TESTING TECHNIQUES
157              
158             C can be used to test web applications for memory leaks.
159              
160             Let's consider you have the following suspicious code
161              
162             sub might_leak {
163             my $t = Test::Mojo->new('MyApp');
164             $t->post_ok('/search.json' => form => {q => 'Perl'})
165             ->status_is(200);
166             ...;
167             }
168              
169             test_noleaks (
170             code => \&might_leak,
171             track_memory => 1,
172             track_fds => 1,
173             passes => 1000,
174             );
175              
176             The C subroutine isn't optimal for leak detection, because it
177             mixes infrastructure-related code (application) with request code. Let's
178             consider, that there is a leak: every request creates some data and puts
179             it into application, but forgets to do clean up. As soon as the application
180             is re-created on every pass, the leaked data might be destroyed together
181             with the application, and leak might remain undetected.
182              
183             So, the code under test should look much more production like, i.e.
184              
185             my $t = Test::Mojo->new('MyApp');
186             ok($t);
187             sub might_leak {
188             $t->post_ok('/search.json' => form => {q => 'Perl'})
189             ->status_is(200);
190             ...;
191             }
192              
193             That way web-application is created only once, and leaks will be tracked
194             on request-related code.
195              
196             Anyway, C still wrong, because it unintentionally leaks due to
197             use of direct or indirect L functions, like C or
198             C. They should not be used; if you still need to assert, that
199             C works propertly, you can use C subroutine,
200             to cancel any further testing, e.g.
201              
202             sub might_leak {
203             my $got = some_function_might_leak;
204             my $expected = "some_value";
205             BAIL_OUT('some_function_might_leak does not work propertly!')
206             unless $got eq $expected;
207             }
208              
209              
210              
211             Please, B use C more then once per test file. Consider
212             the following example:
213              
214             # (A)
215             test_noleaks(
216             code => &does_not_leak_but_consumes_large_amount_of_memory,
217             ...,
218             )
219              
220             # (B)
221             test_noleaks(
222             code => &leaks_but_consumes_small_amount_of_memory,
223             ...
224             )
225              
226             In A-case OS already allocated large amount of memory for Perl interpreter.
227             In case-B perl might just re-use them, without allocating new ones, and
228             this will be false negative, i.e. memory leak might B be reported.
229              
230              
231             =head1 LIMITATIONS
232              
233             =over 2
234              
235             =item * Currently it works propertly only on B
236              
237             Patches or pull requests to support other OSes are welcome.
238              
239             =item * The module will not work propertly in Bed child
240              
241             It seems a little bit strange to use C or
242             C in forked child, but if you really need that, please,
243             send PR.
244              
245             =back
246              
247             =head1 SEE ALSO
248              
249             L
250              
251             =cut
252              
253             my $PAGE_SIZE;
254              
255             BEGIN {
256 5     5   19 no strict "subs";
  5         5  
  5         824  
257              
258 5 50   5   34 $PAGE_SIZE = sysconf(_SC_PAGESIZE)
259             or die("page size cannot be determined, Test::NoLeaks cannot be used");
260              
261 5 50       177 open(my $statm, '<', '/proc/self/statm')
262             or die("couldn't access /proc/self/status : $!");
263             *_platform_mem_size = sub {
264 30081     30081   49520 my $line = <$statm>;
265 30081         27123 seek($statm, 0, 0);
266 30081         49041 my ($pages) = (split / /, $line)[0];
267 30081         37617 return $pages * $PAGE_SIZE;
268 5         19 };
269              
270 5         7 my $fd_dir = '/proc/self/fd';
271 5 50       130 opendir(my $dh, $fd_dir)
272             or die "can't opendir $fd_dir: $!";
273             *_platform_fds = sub {
274 30074     30074   100149 my $open_fd_count = () = readdir($dh);
275 30074         34700 rewinddir($dh);
276 30074         20780 return $open_fd_count;
277 5         2632 };
278             }
279              
280             sub _noleaks {
281 12     12   21 my %args = @_;
282              
283             # check arguments
284 12         17 my $code = $args{code};
285 12 50 33     64 die("code argument (CODEREF) isn't provided")
286             if (!$code || !(ref($code) eq 'CODE'));
287              
288 12         14 my $track_memory = $args{'track_memory'};
289 12         10 my $track_fds = $args{'track_fds'};
290 12 50 66     29 die("don't know what to track (i.e. no 'track_memory' nor 'track_fds' are specified)")
291             if (!$track_memory && !$track_fds);
292              
293 12   50     26 my $passes = $args{passes} || 100;
294 12 50       34 die("passes count too small (should be at least 2)")
295             if $passes < 2;
296              
297 12   100     33 my $warmup_passes = $args{warmup_passes} || 0;
298 12 50       21 die("warmup_passes count too small (should be non-negative)")
299             if $passes < 0;
300              
301             # warm-up phase
302             # a) warm up code
303 12         36 $code->() for (1 .. $warmup_passes);
304              
305             # b) warm-up package itself, as it might cause additional memory (re) allocations
306             # (ignore results)
307 12 100       2142 _platform_mem_size if $track_memory;
308 12 100       33 _platform_fds if $track_fds;
309 12         148 my @leaked_at = map { [0, 0] } (1 .. $passes); # index: pass, value array[$mem_leak, $fds_leak]
  15042         13268  
310              
311             # pre-allocate all variables, including those, which are used in cycle only
312 12         444 my ($total_mem_leak, $total_fds_leak, $memory_hits) = (0, 0, 0);
313 12         14 my ($mem_t0, $fds_t0, $mem_t1, $fds_t1) = (0, 0, 0, 0);
314              
315             # execution phase
316 12         61 for my $pass (0 .. $passes - 1) {
317 15042 100       20865 $mem_t0 = _platform_mem_size if $track_memory;
318 15042 100       22088 $fds_t0 = _platform_fds if $track_fds;
319 15042         15396 $code->();
320 15042 100       517302 $mem_t1 = _platform_mem_size if $track_memory;
321 15042 100       22864 $fds_t1 = _platform_fds if $track_fds;
322              
323 15042         10550 my $leaked_mem = $mem_t1 - $mem_t0;
324 15042 50       17372 $leaked_mem = 0 if ($leaked_mem < 0);
325              
326 15042         9137 my $leaked_fds = $fds_t1 - $fds_t0;
327 15042 50       15004 $leaked_fds = 0 if ($leaked_fds < 0);
328              
329 15042         11393 $leaked_at[$pass]->[0] = $leaked_mem;
330 15042         8656 $leaked_at[$pass]->[1] = $leaked_fds;
331 15042         9028 $total_mem_leak += $leaked_mem;
332 15042         8151 $total_fds_leak += $leaked_fds;
333              
334 15042 100       18391 $memory_hits++ if ($leaked_mem > 0);
335             }
336              
337 12         50 return ($total_mem_leak, $total_fds_leak, $memory_hits, \@leaked_at);
338             }
339              
340              
341              
342             sub noleaks(%) {
343 11     11 1 73 my %args = @_;
344              
345 11         34 my ($mem, $fds, $mem_hits) = _noleaks(%args);
346              
347 11   100     1232 my $tolerate_hits = $args{tolerate_hits} || 0;
348 11         11 my $track_memory = $args{'track_memory'};
349 11         12 my $track_fds = $args{'track_fds'};
350              
351 11   100     44 my $has_fd_leaks = $track_fds && ($fds > 0);
352 11   100     53 my $has_mem_leaks = $track_memory && ($mem > 0) && ($mem_hits > $tolerate_hits);
353 11   100     96 return !($has_fd_leaks || $has_mem_leaks);
354             }
355              
356             sub test_noleaks(%) {
357 1     1 1 12 my %args = @_;
358 1         4 my ($mem, $fds, $mem_hits, $details) = _noleaks(%args);
359              
360 1   50     5 my $tolerate_hits = $args{tolerate_hits} || 0;
361 1         2 my $track_memory = $args{'track_memory'};
362 1         1 my $track_fds = $args{'track_fds'};
363              
364 1   33     8 my $has_fd_leaks = $track_fds && ($fds > 0);
365 1   33     4 my $has_mem_leaks = $track_memory && ($mem > 0) && ($mem_hits > $tolerate_hits);
366 1   33     3 my $has_leaks = $has_fd_leaks || $has_mem_leaks;
367              
368 1         2 local $Test::Builder::Level = $Test::Builder::Level + 1;
369 1 50       2 if (!$has_leaks) {
370 1         3 pass("no leaks have been found");
371             } else {
372 0 0         my $summary = "Leaked "
    0          
373             . ($track_memory ? "$mem bytes ($mem_hits hits) " : "")
374             . ($track_fds ? "$fds file descriptors" : "");
375              
376 0           my @lines;
377 0           for my $pass (1 .. @$details) {
378 0           my $v = $details->[$pass-1];
379 0           my ($mem, $fds) = @$v;
380 0 0 0       if ($mem || $fds) {
381 0 0         my $line = "pass $pass, leaked: "
    0          
382             . ($track_memory ? $mem . " bytes " : "")
383             . ($track_fds ? $fds . " file descriptors" : "");
384 0           push @lines, $line;
385             }
386             }
387 0           my $report = join("\n", @lines);
388              
389 0           note($report);
390 0           fail("$summary");
391             }
392             }
393              
394             =head1 SOURCE CODE
395              
396             L
397              
398             =head1 AUTHOR
399              
400             binary.com, C<< >>
401              
402             =head1 BUGS
403              
404             Please report any bugs or feature requests to
405             L.
406              
407             =head1 LICENSE AND COPYRIGHT
408              
409             Copyright (C) 2015, 2016 binary.com
410              
411             This program is free software; you can redistribute it and/or modify it
412             under the terms of the the Artistic License (2.0). You may obtain a
413             copy of the full license at:
414              
415             L
416              
417             Any use, modification, and distribution of the Standard or Modified
418             Versions is governed by this Artistic License. By using, modifying or
419             distributing the Package, you accept this license. Do not use, modify,
420             or distribute the Package, if you do not accept this license.
421              
422             If your Modified Version has been derived from a Modified Version made
423             by someone other than you, you are nevertheless required to ensure that
424             your Modified Version complies with the requirements of this license.
425              
426             This license does not grant you the right to use any trademark, service
427             mark, tradename, or logo of the Copyright Holder.
428              
429             This license includes the non-exclusive, worldwide, free-of-charge
430             patent license to make, have made, use, offer to sell, sell, import and
431             otherwise transfer the Package with respect to any patent claims
432             licensable by the Copyright Holder that are necessarily infringed by the
433             Package. If you institute patent litigation (including a cross-claim or
434             counterclaim) against any party alleging that the Package constitutes
435             direct or contributory patent infringement, then this Artistic License
436             to you shall terminate on the date that such litigation is filed.
437              
438             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
439             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
440             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
441             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
442             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
443             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
444             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
445             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
446              
447             =cut
448              
449             1;