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.
+
+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.
+
+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.
=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