use strict;
use warnings;
-use Carp qw/croak/;
-use POSIX qw/SIGTERM/;
-use Test::More;
-
-use Perl::Destruct::Level level => 3;
-
-use Test::Valgrind::Suppressions;
-
=head1 NAME
-Test::Valgrind - Test Perl code through valgrind.
+Test::Valgrind - Generate suppressions, analyse and test any command with valgrind.
=head1 VERSION
-Version 0.05
+Version 1.11
=cut
-our $VERSION = '0.05';
+our $VERSION = '1.11';
=head1 SYNOPSIS
+ # From the command-line
+ perl -MTest::Valgrind leaky.pl
+
+ # From the command-line, snippet style
+ perl -MTest::Valgrind -e 'leaky()'
+
+ # In a test file
use Test::More;
eval 'use Test::Valgrind';
plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
+ leaky();
- # Code to inspect for memory leaks/errors.
+ # In all the test files of a directory
+ prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t
=head1 DESCRIPTION
-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.
+This module is a front-end to the C<Test::Valgrind::*> API that lets you run Perl code through the C<memcheck> tool of the C<valgrind> memory debugger, to test for memory errors and leaks.
+If they aren't available yet, it will first generate suppressions for the current C<perl> interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>.
+The actual run will then take place, and tests will be passed or failed according to the result of the analysis.
-You can also use it from the command-line to test a given script :
+The complete API is much more versatile than this.
+By declaring an appropriate L<Test::Valgrind::Command> 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.
+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<Test::Valgrind::Action> class.
- 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.
-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 METHODS
-=head1 CONFIGURATION
+=head2 C<analyse [ %options ]>
-You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
+Run a C<valgrind> analysis configured by C<%options> :
=over 4
=item *
-C<< supp => $file >>
+C<< command => $command >>
+
+The L<Test::Valgrind::Command> object (or class name) to use.
-Also use suppressions from C<$file> besides perl's.
+Defaults to L<Test::Valgrind::Command::PerlScript>.
=item *
-C<< no_supp => $bool >>
+C<< tool => $tool >>
+
+The L<Test::Valgrind::Tool> object (or class name) to use.
-If true, do not use any suppressions.
+Defaults to L<Test::Valgrind::Tool::memcheck>.
=item *
-C<< callers => $number >>
+C<< action => $action >>
+
+The L<Test::Valgrind::Action> object (or class name) to use.
+
+Defaults to L<Test::Valgrind::Action::Test>.
-Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
+=item *
+
+C<< file => $file >>
+
+The file name of the script to analyse.
+
+Ignored if you supply your own custom C<command>, but mandatory otherwise.
=item *
-C<< extra => [ @args ] >>
+C<< callers => $number >>
+
+Specify the maximum stack depth studied when valgrind encounters an error.
+Raising this number improves granularity.
-Add C<@args> to valgrind parameters.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
=item *
C<< diag => $bool >>
-If true, print the raw output of valgrind as diagnostics (may be quite verbose).
+If true, print the output of the test script as diagnostics.
+
+Ignored if you supply your own custom C<action>, otherwise defaults to false.
=item *
-C<< no_test => $bool >>
+C<< extra_supps => \@files >>
+
+Also use suppressions from C<@files> besides C<perl>'s.
-If true, do not actually output the plan and the tests results.
+Defaults to empty.
=item *
-C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >>
+C<< no_def_supp => $bool >>
-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
+If true, do not use the default suppression file.
- sub {
- is($_[0], 0, $_[1]);
- (defined $_[0] and $_[0] == 0) : 1 : 0
- }
+Defaults to false.
=back
=cut
-my $run;
+sub analyse {
+ shift;
-sub _counter {
- (defined $_[0] and $_[0] == 0) ? 1 : 0;
-}
+ my %args = @_;
-sub _tester {
- is($_[0], 0, $_[1]);
- _counter(@_);
+ my $instanceof = sub {
+ require Scalar::Util;
+ Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
+ };
+
+ my $cmd = delete $args{command};
+ unless ($cmd->$instanceof('Test::Valgrind::Command')) {
+ require Test::Valgrind::Command;
+ $cmd = Test::Valgrind::Command->new(
+ command => $cmd || 'PerlScript',
+ file => delete $args{file},
+ args => [ '-MTest::Valgrind=run,1' ],
+ );
+ }
+
+ my $tool = delete $args{tool};
+ unless ($tool->$instanceof('Test::Valgrind::Tool')) {
+ require Test::Valgrind::Tool;
+ $tool = Test::Valgrind::Tool->new(
+ tool => $tool || 'memcheck',
+ callers => delete $args{callers},
+ );
+ }
+
+ my $action = delete $args{action};
+ unless ($action->$instanceof('Test::Valgrind::Action')) {
+ require Test::Valgrind::Action;
+ $action = Test::Valgrind::Action->new(
+ action => $action || 'Test',
+ diag => delete $args{diag},
+ );
+ }
+
+ require Test::Valgrind::Session;
+ my $sess = eval {
+ Test::Valgrind::Session->new(
+ min_version => $tool->requires_version,
+ map { $_ => delete $args{$_} } qw/extra_supps no_def_supp/
+ );
+ };
+ unless ($sess) {
+ my $err = $@;
+ $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/;
+ $action->abort($sess, $err);
+ return $action->status($sess);
+ }
+
+ eval {
+ $sess->run(
+ command => $cmd,
+ tool => $tool,
+ action => $action,
+ );
+ };
+ if ($@) {
+ require Test::Valgrind::Report;
+ $action->report($sess, Test::Valgrind::Report->new_diag($@));
+ }
+
+ my $status = $sess->status;
+ $status = 255 unless defined $status;
+
+ return $status;
}
+=head2 C<import [ %options ]>
+
+In the parent process, L</import> calls L</analyse> with the arguments it received itself - except that if no C<file> option was supplied, it tries to pick the first caller context that looks like a script.
+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).
+
+In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>, albeit two side-effects :
+
+=over 4
+
+=item *
+
+L<Perl::Destruct::Level> is loaded and the destruction level is set to C<3>.
+
+=item *
+
+Autoflush on C<STDOUT> is turned on.
+
+=back
+
+=cut
+
+# We use as little modules as possible in run mode so that they don't pollute
+# the analysis. Hence all the requires.
+
+my $run;
+
sub import {
- shift;
- croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak('Optional arguments must be passed as key => value pairs');
+ }
my %args = @_;
- if (!defined $args{run} && !$run) {
- my ($file, $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 $callers = $args{callers};
- $callers = 12 unless defined $callers;
- $callers = int $callers;
- my $vg = Test::Valgrind::Suppressions::VG_PATH;
- if (!$vg || !-x $vg) {
- for (split /:/, $ENV{PATH}) {
- $_ .= '/valgrind';
- if (-x) {
- $vg = $_;
- last;
- }
- }
- if (!$vg) {
- plan skip_all => 'No valgrind executable could be found in your path';
- return;
- }
+
+ if (defined delete $args{run} or $run) {
+ require Perl::Destruct::Level;
+ Perl::Destruct::Level::set_destruct_level(3);
+ {
+ my $oldfh = select STDOUT;
+ $|++;
+ select $oldfh;
}
- pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
- my $pid = fork;
- if (!defined $pid) {
- croak "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): $!";
- my @args = (
- '--tool=memcheck',
- '--leak-check=full',
- '--leak-resolution=high',
- '--num-callers=' . $callers,
- '--error-limit=yes'
- );
- unless ($args{no_supp}) {
- for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
- push @args, '--suppressions=' . $_ if $_;
- }
- }
- if (defined $args{extra} and ref $args{extra} eq 'ARRAY') {
- push @args, @{$args{extra}};
+ $run = 1;
+ return;
+ }
+
+ my $file = delete $args{file};
+ unless (defined $file) {
+ my ($next, $last_pm);
+ for (my $l = 0; 1; ++$l) {
+ $next = (caller $l)[1];
+ last unless defined $next;
+ next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
+ if ($next =~ /\.pmc?$/) {
+ $last_pm = $next;
+ } else {
+ $file = $next;
+ last;
}
- push @args, $^X;
- push @args, '-I' . $_ for @INC;
- push @args, '-MTest::Valgrind=run,1', $file;
- print STDERR "valgrind @args\n" if $args{diag};
- local $ENV{PERL_DESTRUCT_LEVEL} = 3;
- local $ENV{PERL_DL_NONLAZY} = 1;
- exec $vg, @args;
}
- close $wtr or croak "close(\$wtr): $!";
- local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
- plan tests => 5 unless $args{no_test};
- my @tests = (
- 'errors',
- 'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
+ $file = $last_pm unless defined $file;
+ }
+
+ unless (defined $file) {
+ require Test::Builder;
+ Test::Builder->new->diag('Couldn\'t find a valid source file');
+ return;
+ }
+
+ if ($file ne '-e') {
+ exit $class->analyse(
+ file => $file,
+ %args,
);
- my %res = map { $_ => 0 } @tests;
- while (<$rdr>) {
- diag $_ if $args{diag};
- if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
- chomp(my $err = $1);
- diag "Valgrind error: $err";
- $res{$_} = undef for @tests;
- }
- if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
- $res{errors} = int $1;
- } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) {
- my ($cat, $count) = ($1, $2);
- if (exists $res{$cat}) {
- $cat =~ s/\s+/ /g;
- $count =~ s/[.,]//g;
- $res{$cat} = int $count;
- }
- }
- }
- waitpid $pid, 0;
- my $failed = 5;
- my $cb = ($args{no_test} ? \&_counter
- : ($args{cb} ? $args{cb} : \&_tester));
- for (@tests) {
- $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
+ }
+
+ require File::Temp;
+ my $tmp = File::Temp->new;
+
+ require Filter::Util::Call;
+ Filter::Util::Call::filter_add(sub {
+ my $status = Filter::Util::Call::filter_read();
+ if ($status > 0) {
+ print $tmp $_;
+ } elsif ($status == 0) {
+ close $tmp;
+ my $code = $class->analyse(
+ file => $tmp->filename,
+ %args,
+ );
+ exit $code;
}
- exit $failed;
- } else {
- $run = 1;
+ $status;
+ });
+}
+
+=head1 VARIABLES
+
+=head2 C<$dl_unload>
+
+When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at C<END> time by L<DynaLoader/dl_unload_file>.
+
+Since this obfuscates error stack traces, it's disabled by default.
+
+=cut
+
+our $dl_unload;
+
+END {
+ if ($dl_unload and $run and eval { require DynaLoader; 1 }) {
+ my @rest;
+ DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
+ @DynaLoader::dl_librefs = @rest;
}
}
=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.
+Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it.
+You also have a better chance to get more accurate results if your perl is built with debugging enabled.
+Using the latest C<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.
+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. In particular, running this module against test files will obliterate their original test results.
+What your tests output to C<STDOUT> and C<STDERR> is eaten unless you pass the C<diag> option, in which case it will be reprinted as diagnostics.
=head1 DEPENDENCIES
-Valgrind 3.1.0 (L<http://valgrind.org>).
+L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
+
+=head1 SEE ALSO
-L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
+All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
-L<Perl::Destruct::Level>.
+The C<valgrind(1)> man page.
-=head1 SEE ALSO
+L<Test::LeakTrace>.
L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
=head1 BUGS
-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.
+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.
=head1 SUPPORT
=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).
+RafaE<euml>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.
+All you people that showed interest in this module, which motivated me into completely rewriting it.
+
=head1 COPYRIGHT & LICENSE
-Copyright 2008 Vincent Pit, all rights reserved.
+Copyright 2008-2009 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.