]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - lib/Test/Valgrind.pm
Importing Test-Valgrind-0.04.tar.gz
[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind.pm
1 package Test::Valgrind;
2
3 use strict;
4 use warnings;
5
6 use Carp qw/croak/;
7 use POSIX qw/SIGTERM/;
8 use Test::More;
9
10 use Perl::Destruct::Level level => 3;
11
12 use Test::Valgrind::Suppressions;
13
14 =head1 NAME
15
16 Test::Valgrind - Test Perl code through valgrind.
17
18 =head1 VERSION
19
20 Version 0.04
21
22 =cut
23
24 our $VERSION = '0.04';
25
26 =head1 SYNOPSIS
27
28     use Test::More;
29     eval 'use Test::Valgrind';
30     plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
31
32     # Code to inspect for memory leaks/errors.
33
34 =head1 DESCRIPTION
35
36 This module lets you run some code through the B<valgrind> memory debugger, to test it for memory errors and leaks. Just add C<use Test::Valgrind> at the beginning of the code you want to test. Behind the hood, C<Test::Valgrind::import> forks so that the child can basically C<exec 'valgrind', $^X, $0> (except that of course C<$0> isn't right there). The parent then parses the report output by valgrind and pass or fail tests accordingly.
37
38 You can also use it from the command-line to test a given script :
39
40     perl -MTest::Valgrind leaky.pl
41
42 =head1 CONFIGURATION
43
44 You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
45
46 =over 4
47
48 =item C<< supp => $file >>
49
50 Also use suppressions from C<$file> besides perl's.
51
52 =item C<< no_supp => $bool >>
53
54 If true, do not use any suppressions.
55
56 =item C<< callers => $number >>
57
58 Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 50.
59
60 =item C<< extra => [ @args ] >>
61
62 Add C<@args> to valgrind parameters.
63
64 =item C<< diag => $bool >>
65
66 If true, print the raw output of valgrind as diagnostics (may be quite verbose).
67
68 =item C<< no_test => $bool >>
69
70 If true, do not actually output the plan and the tests results.
71
72 =back
73
74 =cut
75
76 my $run;
77
78 sub import {
79  shift;
80  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
81  my %args = @_;
82  if (!defined $args{run} && !$run) {
83   my ($file, $next);
84   my $l = 0;
85   while ($l < 1000) {
86    $next = (caller $l++)[1];
87    last unless defined $next;
88    $file = $next;
89   }
90   return if not $file or $file eq '-e';
91   my $callers = $args{callers} || 50;
92   $callers = int $callers;
93   my $vg = Test::Valgrind::Suppressions::VG_PATH;
94   if (!$vg || !-x $vg) {
95    for (split /:/, $ENV{PATH}) {
96     $_ .= '/valgrind';
97     if (-x) {
98      $vg = $_;
99      last;
100     }
101    }
102    if (!$vg) {
103     plan skip_all => 'No valgrind executable could be found in your path';
104     return;
105    } 
106   }
107   pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
108   my $pid = fork;
109   if (!defined $pid) {
110    croak "fork(): $!";
111   } elsif ($pid == 0) {
112    setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
113    close $rdr or croak "close(\$rdr): $!";
114    open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
115    my @args = (
116     '--tool=memcheck',
117     '--leak-check=full',
118     '--leak-resolution=high',
119     '--num-callers=' . $callers,
120     '--error-limit=yes'
121    );
122    unless ($args{no_supp}) {
123     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
124      push @args, '--suppressions=' . $_ if $_;
125     }
126    }
127    if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
128     push @args, @{$args{extra}};
129    }
130    push @args, $^X;
131    push @args, '-I' . $_ for @INC;
132    push @args, '-MTest::Valgrind=run,1', $file;
133    print STDERR "valgrind @args\n" if $args{diag};
134    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
135    local $ENV{PERL_DL_NONLAZY} = 1;
136    exec $vg, @args if $vg and -x $vg;
137   }
138   close $wtr or croak "close(\$wtr): $!";
139   local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
140   plan tests => 5 unless $args{no_test};
141   my @tests = (
142    'errors',
143    'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
144   );
145   my %res = map { $_ => 0 } @tests;
146   while (<$rdr>) {
147    diag $_ if $args{diag};
148    if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
149     chomp(my $err = $1);
150     diag "Valgrind error: $err";
151     $res{$_} = undef for @tests;
152    }
153    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
154     $res{errors} = int $1;
155    } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
156     my ($cat, $count) = ($1, $2);
157     if (exists $res{$cat}) {
158      $cat =~ s/\s+/ /g;
159      $count =~ s/[.,]//g;
160      $res{$cat} = int $count;
161     }
162    }
163   }
164   waitpid $pid, 0;
165   my $failed = 0;
166   for (@tests) {
167    is($res{$_}, 0, 'valgrind ' . $_) unless $args{no_test};
168    ++$failed if defined $res{$_} and $res{$_} != 0;
169   }
170   exit $failed;
171  } else {
172   $run = 1;
173  }
174 }
175
176 =head1 CAVEATS
177
178 You can't use this module to test code given by the C<-e> command-line switch.
179
180 Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
181
182 This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
183
184 If your tests output to STDERR, everything will be eaten in the process. In particular, running this module against test files will obliterate their original test results.
185
186 =head1 DEPENDENCIES
187
188 Valgrind 3.1.0 (L<http://valgrind.org>).
189
190 L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
191
192 L<Perl::Destruct::Level>.
193
194 =head1 AUTHOR
195
196 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
197
198 You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
199
200 =head1 BUGS
201
202 Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
203
204 =head1 SUPPORT
205
206 You can find documentation for this module with the perldoc command.
207
208     perldoc Test::Valgrind
209
210 =head1 ACKNOWLEDGEMENTS
211
212 RafaĆ«l Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
213
214 H.Merijn Brand, for daring to test this thing.
215
216 =head1 COPYRIGHT & LICENSE
217
218 Copyright 2008 Vincent Pit, all rights reserved.
219
220 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
221
222 =cut
223
224 1; # End of Test::Valgrind