File Coverage

blib/lib/Test/Valgrind.pm
Criterion Covered Total %
statement 52 123 42.2
branch 15 56 26.7
condition 5 21 23.8
subroutine 7 9 77.7
pod 1 1 100.0
total 80 210 38.1


line stmt bran cond sub pod time code
1             package Test::Valgrind;
2              
3 3     3   2043 use strict;
  3         5  
  3         88  
4 3     3   16 use warnings;
  3         6  
  3         5190  
5              
6             =head1 NAME
7              
8             Test::Valgrind - Generate suppressions, analyse and test any command with valgrind.
9              
10             =head1 VERSION
11              
12             Version 1.17
13              
14             =cut
15              
16             our $VERSION = '1.17';
17              
18             =head1 SYNOPSIS
19              
20             # From the command-line
21             perl -MTest::Valgrind leaky.pl
22              
23             # From the command-line, snippet style
24             perl -MTest::Valgrind -e 'leaky()'
25              
26             # In a test file
27             use Test::More;
28             eval 'use Test::Valgrind';
29             plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
30             leaky();
31              
32             # In all the test files of a directory
33             prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t
34              
35             =head1 DESCRIPTION
36              
37             This module is a front-end to the C API that lets you run Perl code through the C tool of the C memory debugger, to test for memory errors and leaks.
38             If they aren't available yet, it will first generate suppressions for the current C interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>.
39             The actual run will then take place, and tests will be passed or failed according to the result of the analysis.
40              
41             The complete API is much more versatile than this.
42             By declaring an appropriate L class, you can run any executable (that is, not only Perl scripts) under valgrind, generate the corresponding suppressions on-the-fly and convert the analysis result to TAP output so that it can be incorporated into your project's testsuite.
43             If you're not interested in producing TAP, you can output the results in whatever format you like (for example HTML pages) by defining your own L class.
44              
45             Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects.
46             This includes non-mortalized scalars and memory cycles.
47             However, it can track leaks of chunks of memory allocated in XS extensions with C and friends or C.
48             As such, it's complementary to the other very good leak detectors listed in the L section.
49              
50             =head1 METHODS
51              
52             =head2 C
53              
54             Test::Valgrind->analyse(%options);
55              
56             Run a C analysis configured by C<%options> :
57              
58             =over 4
59              
60             =item *
61              
62             C<< command => $command >>
63              
64             The L object (or class name) to use.
65              
66             Defaults to L.
67              
68             =item *
69              
70             C<< tool => $tool >>
71              
72             The L object (or class name) to use.
73              
74             Defaults to L.
75              
76             =item *
77              
78             C<< action => $action >>
79              
80             The L object (or class name) to use.
81              
82             Defaults to L.
83              
84             =item *
85              
86             C<< file => $file >>
87              
88             The file name of the script to analyse.
89              
90             Ignored if you supply your own custom C, but mandatory otherwise.
91              
92             =item *
93              
94             C<< callers => $number >>
95              
96             Specify the maximum stack depth studied when valgrind encounters an error.
97             Raising this number improves granularity.
98              
99             Ignored if you supply your own custom C, otherwise defaults to C<50>.
100              
101             =item *
102              
103             C<< diag => $bool >>
104              
105             If true, print the output of the test script as diagnostics.
106              
107             Ignored if you supply your own custom C, otherwise defaults to false.
108              
109             =item *
110              
111             C<< regen_def_supp => $bool >>
112              
113             If true, forcefully regenerate the default suppression file.
114              
115             Defaults to false.
116              
117             =item *
118              
119             C<< no_def_supp => $bool >>
120              
121             If true, do not use the default suppression file.
122              
123             Defaults to false.
124              
125             =item *
126              
127             C<< allow_no_supp => $bool >>
128              
129             If true, force running the analysis even if the suppression files do not refer to any C-related symbol.
130              
131             Defaults to false.
132              
133             =item *
134              
135             C<< extra_supps => \@files >>
136              
137             Also use suppressions from C<@files> besides C's.
138              
139             Defaults to empty.
140              
141             =back
142              
143             =cut
144              
145             sub _croak {
146 0     0   0 require Carp;
147 0         0 Carp::croak(@_);
148             }
149              
150             my %skippable_errors = (
151             session => [
152             'Empty valgrind candidates list',
153             'No appropriate valgrind executable could be found',
154             ],
155             action => [ ],
156             tool => [ ],
157             command => [ ],
158             run => [
159             'No compatible suppressions available',
160             ],
161             );
162              
163             my %filter_errors;
164              
165             for my $obj (keys %skippable_errors) {
166             my @errors = @{$skippable_errors{$obj} || []};
167             if (@errors) {
168             my $rxp = join '|', @errors;
169             $rxp = qr/($rxp)\s+at.*/;
170             $filter_errors{$obj} = sub {
171             my ($err) = @_;
172             if ($err =~ /$rxp/) {
173             return ($1, 1);
174             } else {
175             return ($err, 0);
176             }
177             };
178             } else {
179             $filter_errors{$obj} = sub {
180             return ($_[0], 0);
181             };
182             }
183             }
184              
185             sub _default_abort {
186 3     3   7 my ($err) = @_;
187              
188 3         17 require Test::Builder;
189 3         29 my $tb = Test::Builder->new;
190 3         107 my $plan = $tb->has_plan;
191 3 50       31 if (defined $plan) {
192 0         0 $tb->BAIL_OUT($err);
193 0         0 return 255;
194             } else {
195 3         16 $tb->skip_all($err);
196 0         0 return 0;
197             }
198             }
199              
200             sub analyse {
201 3     3 1 6 shift;
202              
203 3         9 my %args = @_;
204              
205             my $instanceof = sub {
206 3     3   17 require Scalar::Util;
207 3 50       60 Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
208 3         11 };
209              
210 3         7 my $tool = delete $args{tool};
211 3 50       13 unless ($tool->$instanceof('Test::Valgrind::Tool')) {
212 3         1804 require Test::Valgrind::Tool;
213 3         9 local $@;
214 3         6 $tool = eval {
215             Test::Valgrind::Tool->new(
216             tool => $tool || 'memcheck',
217             callers => delete $args{callers},
218 3   50     30 );
219             };
220 3 50       14 unless ($tool) {
221 0         0 my ($err, $skippable) = $filter_errors{tool}->($@);
222 0 0       0 _croak($err) unless $skippable;
223 0         0 return _default_abort($err);
224             }
225             }
226              
227 3         1897 require Test::Valgrind::Session;
228 3         12 my $sess = eval {
229             Test::Valgrind::Session->new(
230             min_version => $tool->requires_version,
231 3         24 map { $_ => delete $args{$_} } qw<
  12         38  
232             regen_def_supp
233             no_def_supp
234             allow_no_supp
235             extra_supps
236             >
237             );
238             };
239 3 50       17 unless ($sess) {
240 3         14 my ($err, $skippable) = $filter_errors{session}->($@);
241 3 50       14 _croak($err) unless $skippable;
242 3         11 return _default_abort($err);
243             }
244              
245 0         0 my $action = delete $args{action};
246 0 0       0 unless ($action->$instanceof('Test::Valgrind::Action')) {
247 0         0 require Test::Valgrind::Action;
248 0         0 local $@;
249 0         0 $action = eval {
250             Test::Valgrind::Action->new(
251             action => $action || 'Test',
252             diag => delete $args{diag},
253 0   0     0 );
254             };
255 0 0       0 unless ($action) {
256 0         0 my ($err, $skippable) = $filter_errors{action}->($@);
257 0 0       0 _croak($err) unless $skippable;
258 0         0 return _default_abort($err);
259             }
260             }
261              
262 0         0 my $cmd = delete $args{command};
263 0 0       0 unless ($cmd->$instanceof('Test::Valgrind::Command')) {
264 0         0 require Test::Valgrind::Command;
265 0         0 local $@;
266 0         0 $cmd = eval {
267             Test::Valgrind::Command->new(
268             command => $cmd || 'PerlScript',
269             file => delete $args{file},
270 0   0     0 args => [ '-MTest::Valgrind=run,1' ],
271             );
272             };
273 0 0       0 unless ($cmd) {
274 0         0 my ($err, $skippable) = $filter_errors{command}->($@);
275 0 0       0 _croak($err) unless $skippable;
276 0         0 $action->abort($sess, $err);
277 0         0 return $action->status($sess);
278             }
279             }
280              
281             {
282 0         0 local $@;
  0         0  
283             eval {
284 0         0 $sess->run(
285             command => $cmd,
286             tool => $tool,
287             action => $action,
288             );
289 0         0 1
290 0 0       0 } or do {
291 0         0 my ($err, $skippable) = $filter_errors{run}->($@);
292 0 0       0 if ($skippable) {
293 0         0 $action->abort($sess, $err);
294 0         0 return $action->status($sess);
295             } else {
296 0         0 require Test::Valgrind::Report;
297 0         0 $action->report($sess, Test::Valgrind::Report->new_diag($@));
298             }
299             }
300             }
301              
302 0         0 my $status = $sess->status;
303 0 0       0 $status = 255 unless defined $status;
304              
305 0         0 return $status;
306             }
307              
308             =head2 C
309              
310             use Test::Valgrind %options;
311              
312             In the parent process, L calls L with the arguments it received itself - except that if no C option was supplied, it tries to pick the first caller context that looks like a script.
313             When the analysis ends, it exits with the status returned by the action (for the default TAP-generator action, it's the number of failed tests).
314              
315             In the child process, it just Cs so that the calling code is actually run under C, albeit two side-effects :
316              
317             =over 4
318              
319             =item *
320              
321             L is loaded and the destruction level is set to C<3>.
322              
323             =item *
324              
325             Autoflush on C is turned on.
326              
327             =back
328              
329             =cut
330              
331             # We use as little modules as possible in run mode so that they don't pollute
332             # the analysis. Hence all the requires.
333              
334             my $run;
335              
336             sub import {
337 3     3   25 my $class = shift;
338 3   33     21 $class = ref($class) || $class;
339              
340 3 50       19 _croak('Optional arguments must be passed as key => value pairs') if @_ % 2;
341 3         11 my %args = @_;
342              
343 3 50 33     22 if (defined delete $args{run} or $run) {
344 0         0 require Perl::Destruct::Level;
345 0         0 Perl::Destruct::Level::set_destruct_level(3);
346             {
347 0         0 my $oldfh = select STDOUT;
  0         0  
348 0         0 $|++;
349 0         0 select $oldfh;
350             }
351 0         0 $run = 1;
352 0         0 return;
353             }
354              
355 3         5 my $file = delete $args{file};
356 3 50       12 unless (defined $file) {
357 3         5 my ($next, $last_pm);
358 3         6 for (my $l = 0; 1; ++$l) {
359 3         23 $next = (caller $l)[1];
360 3 50       13 last unless defined $next;
361 3 50       13 next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
362 3 50       15 if ($next =~ /\.pmc?$/) {
363 0         0 $last_pm = $next;
364             } else {
365 3         5 $file = $next;
366 3         7 last;
367             }
368             }
369 3 50       11 $file = $last_pm unless defined $file;
370             }
371              
372 3 50       8 unless (defined $file) {
373 0         0 require Test::Builder;
374 0         0 Test::Builder->new->diag('Couldn\'t find a valid source file');
375 0         0 return;
376             }
377              
378 3 50       10 if ($file ne '-e') {
379 3         27 exit $class->analyse(
380             file => $file,
381             %args,
382             );
383             }
384              
385 0           require File::Temp;
386 0           my $tmp = File::Temp->new;
387              
388 0           require Filter::Util::Call;
389             Filter::Util::Call::filter_add(sub {
390 0     0     my $status = Filter::Util::Call::filter_read();
391 0 0         if ($status > 0) {
    0          
392 0           print $tmp $_;
393             } elsif ($status == 0) {
394 0           close $tmp;
395 0           my $code = $class->analyse(
396             file => $tmp->filename,
397             %args,
398             );
399 0           exit $code;
400             }
401 0           $status;
402 0           });
403             }
404              
405             =head1 VARIABLES
406              
407             =head2 C<$dl_unload>
408              
409             When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at C time by L.
410              
411             Since this obfuscates error stack traces, it's disabled by default.
412              
413             =cut
414              
415             our $dl_unload;
416              
417             END {
418 3 0 33 3   589 if ($dl_unload and $run and eval { require DynaLoader; 1 }) {
  0   33     0  
  0         0  
419 0         0 my @rest;
420 0   0     0 DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
421 0         0 @DynaLoader::dl_librefs = @rest;
422             }
423             }
424              
425             =head1 CAVEATS
426              
427             Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it.
428             You also have a better chance to get more accurate results if your perl is built with debugging enabled.
429             Using the latest C available will also help.
430              
431             This module is not really secure.
432             It's definitely not taint safe.
433             That shouldn't be a problem for test files.
434              
435             What your tests output to C and C is eaten unless you pass the C option, in which case it will be reprinted as diagnostics.
436              
437             =head1 DEPENDENCIES
438              
439             L, L, L, L, L.
440              
441             =head1 SEE ALSO
442              
443             All the C API, including L, L, L and L.
444              
445             The C man page.
446              
447             L.
448              
449             L, L, L.
450              
451             =head1 AUTHOR
452              
453             Vincent Pit, C<< >>, L.
454              
455             You can contact me by mail or on C (vincent).
456              
457             =head1 BUGS
458              
459             Please report any bugs or feature requests to C, or through the web interface at L.
460             I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
461              
462             =head1 SUPPORT
463              
464             You can find documentation for this module with the perldoc command.
465              
466             perldoc Test::Valgrind
467              
468             =head1 ACKNOWLEDGEMENTS
469              
470             RafaEl Garcia-Suarez, for writing and instructing me about the existence of L (Elizabeth Mattijsen is a close second).
471              
472             H.Merijn Brand, for daring to test this thing.
473              
474             David Cantrell, for providing shell access to one of his smokers where the tests were failing.
475              
476             The Debian-perl team, for offering all the feedback they could regarding the build issues they met.
477              
478             All you people that showed interest in this module, which motivated me into completely rewriting it.
479              
480             =head1 COPYRIGHT & LICENSE
481              
482             Copyright 2008,2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
483              
484             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
485              
486             =cut
487              
488             1; # End of Test::Valgrind