use Carp qw/croak/;
use POSIX qw/SIGTERM/;
-use Test::More;
+use Fcntl qw/F_SETFD/;
+use Test::Builder;
+
+use Perl::Destruct::Level level => 3;
use Test::Valgrind::Suppressions;
=head1 NAME
-Test::Valgrind - Test your code through valgrind.
+Test::Valgrind - Test Perl code through valgrind.
=head1 VERSION
-Version 0.01
+Version 0.06
=cut
-our $VERSION = '0.01';
+our $VERSION = '0.06';
=head1 SYNOPSIS
use Test::More;
eval 'use Test::Valgrind';
- plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind';
+ plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
# Code to inspect for memory leaks/errors.
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.
+You can also use it from the command-line to test a given script :
+
+ perl -MTest::Valgrind leaky.pl
+
+Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects. This includes non-mortalized scalars and memory cycles. However, it can track leaks of chunks of memory allocated in XS extensions with C<Newx> and friends or C<malloc>. As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
+
=head1 CONFIGURATION
You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
=over 4
-=item C<< supp => $file >>
+=item *
+
+C<< supp => $file >>
Also use suppressions from C<$file> besides perl's.
-=item C<< no_supp => $bool >>
+=item *
+
+C<< no_supp => $bool >>
If true, do not use any suppressions.
-=item C<< callers => $number >>
+=item *
+
+C<< callers => $number >>
-Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 50.
+Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
-=item C<< extra => [ @args ] >>
+=item *
+
+C<< extra => [ @args ] >>
Add C<@args> to valgrind parameters.
-=item C<< diag => $bool >>
+=item *
+
+C<< diag => $bool >>
If true, print the raw output of valgrind as diagnostics (may be quite verbose).
-=item C<< no_test => $bool >>
+=item *
+
+C<< no_test => $bool >>
If true, do not actually output the plan and the tests results.
+=item *
+
+C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >>
+
+Specifies a subroutine to execute for each test instead of C<Test::More::is>. It receives the number of bytes leaked in C<$_[0]> and the test name in C<$_[1]>, and is expected to return true if the test passed and false otherwise. Defaults to
+
+ sub {
+ is($_[0], 0, $_[1]);
+ (defined $_[0] and $_[0] == 0) : 1 : 0
+ }
+
=back
=cut
+my $Test = Test::Builder->new;
+
my $run;
+sub _counter {
+ (defined $_[0] and $_[0] == 0) ? 1 : 0;
+}
+
+sub _tester {
+ $Test->is_num($_[0], 0, $_[1]);
+ _counter(@_);
+}
+
sub import {
shift;
croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
my %args = @_;
if (!defined $args{run} && !$run) {
- my ($file, $next);
+ my ($file, $pm, $next);
my $l = 0;
while ($l < 1000) {
$next = (caller $l++)[1];
last unless defined $next;
- $file = $next;
- }
- return if not $file or $file eq '-e';
- my $valgrind;
- for (split /:/, $ENV{PATH}) {
- my $vg = $_ . '/valgrind';
- if (-x $vg) {
- $valgrind = $vg;
- last;
+ next unless $next ne '-e' and $next !~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/
+ and -f $next;
+ if ($next =~ /\.pm$/) {
+ $pm = $next;
+ } else {
+ $file = $next;
}
}
- if (!$valgrind) {
- plan skip_all => 'No valgrind executable could be found in your path';
- return;
+ unless (defined $file) {
+ $file = $pm;
+ return unless defined $pm;
}
- my $callers = $args{callers} || 50;
+ my $callers = $args{callers};
+ $callers = 12 unless defined $callers;
$callers = int $callers;
- pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
+ my $vg = Test::Valgrind::Suppressions::VG_PATH;
+ if (!$vg || !-x $vg) {
+ for (split /:/, $ENV{PATH}) {
+ $_ .= '/valgrind';
+ if (-x) {
+ $vg = $_;
+ last;
+ }
+ }
+ if (!$vg) {
+ $Test->skip_all('No valgrind executable could be found in your path');
+ return;
+ }
+ }
+ pipe my $ordr, my $owtr or die "pipe(\$ordr, \$owtr): $!";
+ pipe my $vrdr, my $vwtr or die "pipe(\$vrdr, \$vwtr): $!";
my $pid = fork;
if (!defined $pid) {
- croak "fork(): $!";
+ die "fork(): $!";
} elsif ($pid == 0) {
- setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
- close $rdr or croak "close(\$rdr): $!";
- open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
+ setpgrp 0, 0 or die "setpgrp(0, 0): $!";
+ close $ordr or die "close(\$ordr): $!";
+ open STDOUT, '>&=', $owtr or die "open(STDOUT, '>&=', \$owtr): $!";
+ close $vrdr or die "close(\$vrdr): $!";
+ fcntl $vwtr, F_SETFD, 0 or die "fcntl(\$vwtr, F_SETFD, 0): $!";
my @args = (
+ $vg,
'--tool=memcheck',
'--leak-check=full',
'--leak-resolution=high',
'--num-callers=' . $callers,
- '--error-limit=yes'
+ '--error-limit=yes',
+ '--log-fd=' . fileno($vwtr)
);
unless ($args{no_supp}) {
- for (Test::Valgrind::Suppressions::supppath(), $args{supp}) {
+ for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
push @args, '--suppressions=' . $_ if $_;
}
}
push @args, $^X;
push @args, '-I' . $_ for @INC;
push @args, '-MTest::Valgrind=run,1', $file;
- print STDERR "valgrind @args\n" if $args{diag};
+ print STDOUT "valgrind @args\n";
local $ENV{PERL_DESTRUCT_LEVEL} = 3;
local $ENV{PERL_DL_NONLAZY} = 1;
- exec 'valgrind', @args;
+ exec { $args[0] } @args;
+ die "exec @args: $!";
}
- close $wtr or croak "close(\$wtr): $!";
local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
- plan tests => 5 unless $args{no_test};
+ $Test->plan(tests => 5) unless $args{no_test} or defined $Test->has_plan;
my @tests = (
'errors',
'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
);
my %res = map { $_ => 0 } @tests;
- while (<$rdr>) {
- diag $_ if $args{diag};
+ close $owtr or die "close(\$owtr): $!";
+ close $vwtr or die "close(\$vwtr): $!";
+ while (<$vrdr>) {
+ $Test->diag($_) if $args{diag};
if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
chomp(my $err = $1);
- diag "Valgrind error: $err";
+ $Test->diag("Valgrind error: $err");
$res{$_} = undef for @tests;
}
if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
}
}
waitpid $pid, 0;
- my $failed = 0;
+ $Test->diag(do { local $/; <$ordr> }) if $args{diag};
+ close $ordr or die "close(\$ordr): $!";
+ my $failed = 5;
+ my $cb = ($args{no_test} ? \&_counter
+ : ($args{cb} ? $args{cb} : \&_tester));
for (@tests) {
- is($res{$_}, 0, 'valgrind ' . $_) unless $args{no_test};
- ++$failed if defined $res{$_} and $res{$_} != 0;
+ $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
}
exit $failed;
} else {
=head1 CAVEATS
You can't use this module to test code given by the C<-e> command-line switch.
+
+Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be very accurate on it. Anyhow, results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
+
This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
-If your tests output to STDERR, everything will be eaten in the process.
+
+What your tests output to STDOUT is eaten unless you pass the C<diag> option, in which case it will be reprinted as diagnostics. STDERR is kept untouched.
=head1 DEPENDENCIES
Valgrind 3.1.0 (L<http://valgrind.org>).
-L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
+L<Carp>, L<Fcntl>, L<POSIX> (core modules since perl 5) and L<Test::Builder> (since 5.6.2).
+
+L<Perl::Destruct::Level>.
+
+=head1 SEE ALSO
+
+L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
=head1 AUTHOR
perldoc Test::Valgrind
+=head1 ACKNOWLEDGEMENTS
+
+Rafaël Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
+
+H.Merijn Brand, for daring to test this thing.
+
=head1 COPYRIGHT & LICENSE
Copyright 2008 Vincent Pit, all rights reserved.
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
=cut
projects / perl / modules / Test-Valgrind.git / blobdiff