*.tar.gz
Test-Valgrind-*
-lib/Test/Valgrind/perlTestValgrind.supp
core.*
*.[co]
Revision history for Test-Valgrind
+1.00 2009-04-12 22:50 UTC
+ Complete rewrite. The options passed to Test::Valgrind->import have
+ changed, so please have a look at the doc.
+ + Add : A brand new reusable API.
+ + Add : Suppressions are now versionized following the perl interpreter
+ and valgrind. They are regenerated as needed and stored in the
+ user home directory.
+ + Add : memcheck output is parsed by XML::Twig.
+ + Add : The output of the original script is now correctly captured.
+ + Rem : Lots of ugly hacks in the toolchain.
+
0.08 2009-02-08 18:25 UTC
+ Add : Unload the libraries loaded by DynaLoader at END time, reducing
the number of leaks in perl.
+++ /dev/null
-use strict;
-use warnings;
-
-use File::Copy qw/copy/;
-
-my ($bak) = @ARGV;
-exit 1 unless defined $bak;
-
-my $mk = './Makefile';
-exit 1 unless defined $mk and -e $mk and -r _ and -w _;
-
-select STDERR;
-
-print "Fixing Makefile install targets\n";
-
-if (-e $bak && (stat $bak)[9] >= (stat $mk)[9]) { # mtime
- print "Makefile is old\n";
- copy($bak, $mk);
-} else {
- print "Makefile is new\n";
- copy($mk, $bak);
-}
-
-open my $in, '<', $bak or die "open(<$bak): $!";
-open my $out, '>', $mk or die "open(>$mk): $!";
-while (<$in>) {
- s!^(\s*)\$\(INST_ARCHLIB\)\s+(\$\(DESTINSTALL(?:ARCHLIB|SITEARCH|VENDORARCH)\))\s*\\\s*!$1blib/archpub $2 \\\n!g;
- print $out $_;
-}
-close $out;
-close $in;
-
-utime time, time, $bak; # Update mtime
+++ /dev/null
-use strict;
-use warnings;
-
-my ($sf) = @ARGV;
-exit 1 unless defined $sf;
-
-my $file = './gen.pl';
-
-pipe my $rdr, my $wtr or die "pipe(\$rdr, \$wtr): $!";
-my $pid = fork;
-if (!defined $pid) {
- die "fork(): $!";
-} elsif ($pid == 0) {
- close $rdr or die "close(\$rdr): $!";
- open STDERR, '>&', $wtr or die "open(STDERR, '>&', \$wtr): $!";
- exec $^X, '-Mlib=lib', $file;
-}
-close $wtr or die "close(\$rdr): $!";
-
-my ($s, $in, @supps) = ('', 0);
-while (<$rdr>) {
- s/^\s*#\s//;
- next if /^==/;
- next if /valgrind/ and /\Q$file\E/;
- s/^\s*//;
- s/<[^>]+>//;
- s/\s*$//;
- next unless length;
- if ($_ eq '{') {
- $in = 1;
- } elsif ($_ eq '}') {
- push @supps, $s;
- $s = '';
- $in = 0;
- } elsif ($in) {
- $s .= "$_\n";
- }
-}
-waitpid $pid, 0;
-
-select STDERR;
-
-my $a = @supps;
-print "Found $a suppressions\n";
-
-my @extra;
-for (@supps) {
- if (/\bfun:(m|c|re)alloc\b/) {
- my $t = $1;
- my %call;
- if ($t eq 'm') { # malloc can also be called by calloc or realloc
- $call{$_} = 1 for qw/calloc realloc/;
- } elsif ($t eq 're') { # realloc can also call malloc or free
- $call{$_} = 0 for qw/malloc free/;
- } elsif ($t eq 'c') { # calloc can also call malloc
- $call{$_} = 0 for qw/malloc/;
- }
- my $c = $_;
- for (keys %call) {
- my $d = $c;
- $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
- # Remove one line for each line added or valgrind will hate us
- $d =~ s/\n(.+?)\s*$/\n/;
- push @extra, $d;
- }
- }
-}
-my $e = @extra;
-print "Generated $e extra suppressions\n";
-
-my %dupes;
-@dupes{@supps, @extra} = ();
-@supps = keys %dupes;
-my $b = @supps;
-print "Removed " . (($a + $e) - $b) . " duplicates\n";
-
-my ($name, $num) = ('perlTestValgrind', 0);
-
-1 while unlink $sf;
-
-open my $out, '>', $sf or die "$!";
-print $out "{\n$name" . (++$num) . "\n$_}\n" for @supps;
-close $out;
Changes
-FixInstall.PL
-Gensupp.PL
MANIFEST
+META.yml
Makefile.PL
README
Valgrind.xs
-gen.pl
lib/Test/Valgrind.pm
-lib/Test/Valgrind/perlTestValgrind.supp
+lib/Test/Valgrind/Action.pm
+lib/Test/Valgrind/Action/Captor.pm
+lib/Test/Valgrind/Action/Suppressions.pm
+lib/Test/Valgrind/Action/Test.pm
+lib/Test/Valgrind/Carp.pm
+lib/Test/Valgrind/Command.pm
+lib/Test/Valgrind/Command/Perl.pm
+lib/Test/Valgrind/Report.pm
+lib/Test/Valgrind/Session.pm
lib/Test/Valgrind/Suppressions.pm
-lib/Test/Valgrind/Suppressions.tpl
+lib/Test/Valgrind/Tool.pm
+lib/Test/Valgrind/Tool/SuppressionsParser.pm
+lib/Test/Valgrind/Tool/memcheck.pm
samples/map.pl
+samples/xml-output.txt
t/00-load.t
-t/01-import.t
-t/10-suppressions.t
-t/20-good.t
-t/30-bad.t
-t/90-boilerplate.t
+t/10-good.t
+t/20-bad.t
+t/80-suppressions.t
t/91-pod.t
t/92-pod-coverage.t
t/95-portability-files.t
t/99-kwalitee.t
-META.yml Module meta-data (added by MakeMaker)
+t/lib/Test/Valgrind/Test/Action.pm
--- #YAML:1.0
name: Test-Valgrind
-version: 0.08
+version: 1.00
abstract: Test Perl code through valgrind.
author:
- Vincent Pit <perl@profvince.com>
license: perl
distribution_type: module
configure_requires:
+ Carp: 0
Config: 0
ExtUtils::MakeMaker: 0
+ Fcntl: 0
File::Spec: 0
+ POSIX: 0
+ Scalar::Util: 0
+ version: 0
build_requires:
+ Carp: 0
+ Digest::MD5: 0
+ Env::Sanctify: 0
ExtUtils::MakeMaker: 0
+ Fcntl: 0
File::Copy: 0
+ File::HomeDir: 0.86
+ File::Path: 0
+ File::Spec: 0
+ File::Temp: 0
+ Perl::Destruct::Level: 0
+ POSIX: 0
+ Scalar::Util: 0
+ Test::Builder: 0
Test::More: 0
+ version: 0
+ XML::Twig: 0
requires:
Carp: 0
- Exporter: 0
+ Digest::MD5: 0
+ Env::Sanctify: 0
Fcntl: 0
+ File::HomeDir: 0.86
+ File::Path: 0
+ File::Spec: 0
+ File::Temp: 0
perl: 5.006
Perl::Destruct::Level: 0
POSIX: 0
+ Scalar::Util: 0
Test::Builder: 0
+ version: 0
+ XML::Twig: 0
resources:
bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind
homepage: http://search.cpan.org/dist/Test-Valgrind/
directory:
- t
- inc
-generated_by: ExtUtils::MakeMaker version 6.48
+generated_by: ExtUtils::MakeMaker version 6.50
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
use warnings;
use ExtUtils::MakeMaker;
+my $has_version_pm;
BEGIN {
eval { require Config };
die 'OS unsupported' if $@;
Config->import(qw/%Config/);
eval { require File::Spec };
die 'OS unsupported' if $@;
+ $has_version_pm = eval "require version; 1" || 0;
}
+use lib 'lib';
-my $vg;
-print 'Checking for valgrind >= 3.1.0 in PATH... ';
-for (split /$Config{path_sep}/, $ENV{PATH}) {
- $_ .= '/valgrind';
- if (-x) {
- my $ver = qx/$_ --version/;
- if ($ver =~ s/^valgrind-//) {
- $ver = join '', map chr, split /\./, $ver;
- if ($ver ge v3.1.0) {
- print "$_\n";
- $vg = $_;
- last;
- }
- }
- }
-}
-if (!$vg) {
+print 'Checking for valgrind ' . ('>= 3.1.0 ' x $has_version_pm) .'in PATH... ';
+require Test::Valgrind::Session;
+my $vg = eval q[
+ Test::Valgrind::Session->new((min_version => '3.1.0') x $has_version_pm)
+ ->valgrind
+];
+if ($vg) {
+ print "$vg\n";
+} else {
print "no\n";
die 'OS unsupported';
}
print "Checking for a valid C compiler in the PATH... ";
my @ccs = ($Config{cc});
unshift @ccs, $ENV{CC} if $ENV{CC};
-my $cc;
+my @path = File::Spec->path;
+@ccs = map {
+ my $cc = $_;
+ File::Spec->file_name_is_absolute($cc)
+ ? $cc
+ : map File::Spec->catfile($_, $cc), @path
+} @ccs;
+my $has_cc;
CC:
-for my $c (@ccs) {
- for my $dir (split /$Config{path_sep}/, $ENV{PATH}) {
- my $abs = File::Spec->catfile($dir, $c);
- if (-x $abs or MM->maybe_command($abs)) {
- $cc = $c;
- last CC;
- }
+for my $cc (@ccs) {
+ if (-x $cc or MM->maybe_command($cc)) {
+ $has_cc = $cc;
+ last CC;
}
}
my (@C);
-if ($cc) {
+if ($has_cc) {
my $xs = 'Valgrind.xs';
(my $c = $xs) =~ s/\.xs$/.c/;
push @C, $c;
- print $cc, "\n";
+ print $has_cc, "\n";
} else {
print "none\n";
}
+my %PREREQ_PM = (
+ 'Carp' => 0,
+ 'Digest::MD5' => 0,
+ 'Env::Sanctify' => 0,
+ 'File::HomeDir' => '0.86',
+ 'File::Path' => 0,
+ 'File::Spec' => 0,
+ 'File::Temp' => 0,
+ 'Fcntl' => 0,
+ 'POSIX' => 0,
+ 'Perl::Destruct::Level' => 0,
+ 'Scalar::Util' => 0,
+ 'Test::Builder' => 0,
+ 'XML::Twig' => 0,
+ 'version' => 0,
+);
+
my $dist = 'Test-Valgrind';
my %META = (
configure_requires => {
+ 'Carp' => 0,
'Config' => 0,
'ExtUtils::MakeMaker' => 0,
+ 'Fcntl' => 0,
'File::Spec' => 0,
+ 'POSIX' => 0,
+ 'Scalar::Util' => 0,
+ 'version' => 0,
},
build_requires => {
'ExtUtils::MakeMaker' => 0,
- 'File::Copy' => 0,
'Test::More' => 0,
+ %PREREQ_PM,
},
recommends => {
'DynaLoader' => 0,
},
);
-my $supp = 'lib/Test/Valgrind/Suppressions';
-open my $tpl, '<', $supp . '.tpl' or die "open($supp.tpl): $!";
-open my $out, '>', $supp . '.pm' or die "open($supp.pm): $!";
-while (<$tpl>) {
- s/(VG_PATH\s*=>\s*)undef/$1'$vg'/g;
- print $out $_;
-}
-close $out;
-close $tpl;
-
-$supp = 'Test/Valgrind/perlTestValgrind.supp';
-
WriteMakefile(
NAME => 'Test::Valgrind',
AUTHOR => 'Vincent Pit <perl@profvince.com>',
LICENSE => 'perl',
VERSION_FROM => 'lib/Test/Valgrind.pm',
ABSTRACT_FROM => 'lib/Test/Valgrind.pm',
- PL_FILES => {
- './Gensupp.PL' => 'blib/archpub/' . $supp,
- './FixInstall.PL' => 'Makefile.bak',
- },
OPTIMIZE => '-g',
- PM => {
- 'lib/Test/Valgrind.pm'
- => '$(INST_LIB)/Test/Valgrind.pm',
- 'lib/Test/Valgrind/Suppressions.pm'
- => 'blib/archpub/Test/Valgrind/Suppressions.pm',
- },
C => \@C,
- PREREQ_PM => {
- 'Carp' => 0,
- 'Exporter' => 0,
- 'Fcntl' => 0,
- 'POSIX' => 0,
- 'Perl::Destruct::Level' => 0,
- 'Test::Builder' => 0,
- },
+ PREREQ_PM => \%PREREQ_PM,
MIN_PERL_VERSION => 5.006,
META_MERGE => \%META,
dist => {
- PREOP => "touch lib/$supp; "
- . 'pod2text lib/Test/Valgrind.pm > $(DISTVNAME)/README',
+ PREOP => 'pod2text lib/Test/Valgrind.pm > $(DISTVNAME)/README',
COMPRESS => 'gzip -9f', SUFFIX => 'gz',
},
clean => {
- FILES => "$dist-* lib/$supp Makefile.bak *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
+ FILES => "$dist-* Makefile.bak *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
},
);
-1 while unlink 'lib/' . $supp;
-
-package MY;
-
-sub dist_core {
- my $dist = shift->SUPER::dist_core(@_);
- $dist =~ s/^(\s*dist\s*:+\s*)/$1testvg_dist /m;
- return <<DISTCORE . $dist;
-testvg_dist :
- \$(CP) lib/Test/Valgrind/Suppressions.{tpl,pm}
- \$(RM) lib/$supp
- \$(TOUCH) lib/$supp
-DISTCORE
-}
-
-sub test {
- my $test = shift->SUPER::test(@_);
- my ($target) = $test =~ /^\s*(test\s*:+)/m;
- return "$target Makefile.bak blib/archpub/$supp\n$test";
-}
-
-sub postamble {
- return <<POSTAMBLE;
-clean ::
- \$(CP) lib/Test/Valgrind/Suppressions.{tpl,pm}
- \$(TOUCH) lib/$supp
-POSTAMBLE
-}
Test::Valgrind - Test Perl code through valgrind.
VERSION
- Version 0.08
+ Version 1.00
SYNOPSIS
+ # From the command-line
+ perl -MTest::Valgrind leaky.pl
+
+ # 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 $@;
+ ...
- # 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
DESCRIPTION
- This module lets you run some code through the valgrind memory debugger,
- to test it for memory errors and leaks. Just add "use Test::Valgrind" at
- the beginning of the code you want to test. Behind the hood,
- "Test::Valgrind::import" forks so that the child can basically "exec
- 'valgrind', $^X, $0" (except that of course $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
+ This module is a front-end to the "Test::Valgrind::*" API that lets you
+ run Perl code through the "memcheck" tool of the "valgrind" memory
+ debugger, to test it for memory errors and leaks. If they aren't
+ available yet, it will first generate suppressions for the current
+ "perl" interpreter and store them in the portable flavour of
+ ~/.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.
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
You can pass parameters to "import" as a list of key / value pairs,
where valid keys are :
- * "supp => $file"
+ * "tool => $tool"
- Also use suppressions from $file besides perl's.
+ The Test::Valgrind::Tool object (or class name) to use.
- * "no_supp => $bool"
+ Defaults to Test::Valgrind::Tool::memcheck.
- If true, do not use any suppressions.
+ * "action => $action"
- * "callers => $number"
+ The Test::Valgrind::Action object (or class name) to use.
- Specify the maximum stack depth studied when valgrind encounters an
- error. Raising this number improves granularity. Default is 12.
+ Defaults to Test::Valgrind::Action::Test.
- * "extra => [ @args ]"
+ * "diag => $bool"
- Add @args to valgrind parameters.
+ If true, print the output of the test script as diagnostics.
- * "diag => $bool"
+ * "callers => $number"
- If true, print the raw output of valgrind as diagnostics (may be
- quite verbose).
+ Specify the maximum stack depth studied when valgrind encounters an
+ error. Raising this number improves granularity.
- * "no_test => $bool"
+ Default is 12.
- If true, do not actually output the plan and the tests results.
+ * "extra_supps => \@files"
- * "cb => sub { my ($val, $name) = @_; ...; return $passed }"
+ Also use suppressions from @files besides "perl"'s.
- Specifies a subroutine to execute for each test instead of
- "Test::More::is". It receives the number of bytes leaked in $_[0]
- and the test name in $_[1], and is expected to return true if the
- test passed and false otherwise. Defaults to
+ * "no_def_supp => $bool"
- sub {
- is($_[0], 0, $_[1]);
- (defined $_[0] and $_[0] == 0) : 1 : 0
- }
+ If true, do not use the default suppression file.
CAVEATS
You can't use this module to test code given by the "-e" command-line
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.
+ 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.
- What your tests output to STDOUT is eaten unless you pass the "diag"
- option, in which case it will be reprinted as diagnostics. STDERR is
- kept untouched.
+ What your tests output to "STDOUT" and "STDERR" is eaten unless you pass
+ the "diag" option, in which case it will be reprinted as diagnostics.
DEPENDENCIES
Valgrind 3.1.0 (<http://valgrind.org>).
- Carp, Fcntl, POSIX (core modules since perl 5) and Test::Builder (since
- 5.6.2).
-
- Perl::Destruct::Level.
+ XML::Twig, version, File::HomeDir, Env::Sanctify, Perl::Destruct::Level.
SEE ALSO
+ All the "Test::Valgrind::*" API, including Test::Valgrind::Command,
+ Test::Valgrind::Tool, Test::Valgrind::Action and
+ Test::Valgrind::Session.
+
+ Test::LeakTrace.
+
Devel::Leak, Devel::LeakTrace, Devel::LeakTrace::Fast.
AUTHOR
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.
+
COPYRIGHT & LICENSE
Copyright 2008-2009 Vincent Pit, all rights reserved.
# define DEBUGGING 0
#endif
-const char *tvtxs_leaky = NULL;
+const char *tv_leaky = NULL;
/* --- XS ------------------------------------------------------------------ */
void
leak()
CODE:
- Newx(tvtxs_leaky, 10000, char);
+ tv_leaky = malloc(10000);
XSRETURN_UNDEF;
SV *
notleak(SV *sv)
CODE:
- Newx(tvtxs_leaky, 10000, char);
- Safefree(tvtxs_leaky);
+ Newx(tv_leaky, 10000, char);
+ Safefree(tv_leaky);
RETVAL = newSVsv(sv);
OUTPUT:
RETVAL
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More;
-eval {
- use Test::Valgrind
- diag => 1,
- no_test => 1,
- no_supp => 1,
- callers => 50,
- extra => [ qw/--show-reachable=yes --gen-suppressions=all/ ];
-};
-if ($@) {
- plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
-} else {
- eval "
- use lib qw{blib/arch};
- require XSLoader;
- XSLoader::load('Test::Valgrind', \$Test::Valgrind::VERSION);
- ";
- unless ($@) {
- Test::Valgrind::notleak("valgrind it!");
- } else {
- diag $@;
- }
- plan tests => 1;
- fail('fake');
-}
-
-1;
use strict;
use warnings;
-use Carp qw/croak/;
-use POSIX qw/SIGTERM/;
-use Fcntl qw/F_SETFD/;
-use Test::Builder;
-
-use Perl::Destruct::Level level => 3;
-
-use Test::Valgrind::Suppressions;
-
=head1 NAME
Test::Valgrind - Test Perl code through valgrind.
=head1 VERSION
-Version 0.08
+Version 1.00
=cut
-our $VERSION = '0.08';
+our $VERSION = '1.00';
=head1 SYNOPSIS
+ # From the command-line
+ perl -MTest::Valgrind leaky.pl
+
+ # 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 $@;
+ ...
- # 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.
-
-You can also use it from the command-line to test a given script :
+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 it 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.
- 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 CONFIGURATION
=item *
-C<< supp => $file >>
-
-Also use suppressions from C<$file> besides perl's.
-
-=item *
+C<< tool => $tool >>
-C<< no_supp => $bool >>
+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.
-Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
+Defaults to L<Test::Valgrind::Action::Test>.
=item *
-C<< extra => [ @args ] >>
+C<< diag => $bool >>
-Add C<@args> to valgrind parameters.
+If true, print the output of the test script as diagnostics.
=item *
-C<< diag => $bool >>
+C<< callers => $number >>
+
+Specify the maximum stack depth studied when valgrind encounters an error.
+Raising this number improves granularity.
-If true, print the raw output of valgrind as diagnostics (may be quite verbose).
+Default is 12.
=item *
-C<< no_test => $bool >>
+C<< extra_supps => \@files >>
-If true, do not actually output the plan and the tests results.
+Also use suppressions from C<@files> besides C<perl>'s.
=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
-
- sub {
- is($_[0], 0, $_[1]);
- (defined $_[0] and $_[0] == 0) : 1 : 0
- }
+If true, do not use the default suppression file.
=back
=cut
-my $Test = Test::Builder->new;
+# 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 _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;
+
+ if (@_ % 2) {
+ require Carp;
+ Carp::croak('Optional arguments must be passed as key => value pairs');
+ }
my %args = @_;
- if (!defined $args{run} && !$run) {
- my ($file, $pm, $next);
- my $l = 0;
- while ($l < 1000) {
- $next = (caller $l++)[1];
- last unless defined $next;
- 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;
- }
- }
- unless (defined $file) {
- $file = $pm;
- return unless defined $pm;
+
+ if (defined $args{run} or $run) {
+ require Perl::Destruct::Level;
+ Perl::Destruct::Level::set_destruct_level(3);
+ {
+ my $oldfh = select STDOUT;
+ $|++;
+ select $oldfh;
}
- my $callers = $args{callers};
- $callers = 12 unless defined $callers;
- $callers = int $callers;
- my $vg = Test::Valgrind::Suppressions::VG_PATH;
- if (!$vg || !-x $vg) {
- require Config;
- for (split /$Config::Config{path_sep}/, $ENV{PATH}) {
- $_ .= '/valgrind';
- if (-x) {
- $vg = $_;
- last;
- }
- }
- if (!$vg) {
- $Test->skip_all('No valgrind executable could be found in your path');
- return;
- }
+ $run = 1;
+ return;
+ }
+
+ my ($file, $pm, $next);
+ my $l = 0;
+ while ($l < 1000) {
+ $next = (caller $l++)[1];
+ last unless defined $next;
+ next if $next eq '-e' or $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ or !-f $next;
+ if ($next =~ /\.pm$/) {
+ $pm = $next;
+ } else {
+ $file = $next;
}
- 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) {
- die "fork(): $!";
- } elsif ($pid == 0) {
- 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',
- '--log-fd=' . fileno($vwtr)
- );
- 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}};
- }
- push @args, $^X;
- push @args, '-I' . $_ for @INC;
- push @args, '-MTest::Valgrind=run,1', $file;
- print STDOUT "valgrind @args\n";
- local $ENV{PERL_DESTRUCT_LEVEL} = 3;
- local $ENV{PERL_DL_NONLAZY} = 1;
- exec { $args[0] } @args;
- die "exec @args: $!";
+ }
+ unless (defined($file) or defined($file = $pm)) {
+ require Test::Builder;
+ Test::Builder->new->diag('Couldn\'t find a valid source file');
+ return;
+ }
+
+ my $taint_mode;
+ {
+ open my $fh, '<', $file or last;
+ my $first = <$fh>;
+ close $fh;
+ if ($first and my ($args) = $first =~ /^\s*#\s*!\s*perl\s*(.*)/) {
+ $taint_mode = 1 if $args =~ /(?:^|\s)-T(?:$|\s)/;
}
- local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
- $Test->plan(tests => 5) unless $args{no_test} or defined $Test->has_plan;
- my @tests = (
- 'errors',
- 'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
+ }
+
+ require Test::Valgrind::Command;
+ my $cmd = Test::Valgrind::Command->new(
+ command => 'Perl',
+ args => [ '-MTest::Valgrind=run,1', (('-T') x!! $taint_mode), $file ],
+ );
+
+ my $instanceof = sub {
+ require Scalar::Util;
+ Scalar::Util::blessed($_[0]) && $_[0]->isa($_[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 %res = map { $_ => 0 } @tests;
- 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);
- $Test->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;
- $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) {
- $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
- }
- exit $failed;
- } else {
- $run = 1;
}
+
+ 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) {
+ $action->abort($sess, $@);
+ exit $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;
+
+ exit $status;
}
END {
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.
+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 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.
-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.
+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<Carp>, L<Fcntl>, L<POSIX> (core modules since perl 5) and L<Test::Builder> (since 5.6.2).
-
-L<Perl::Destruct::Level>.
+L<XML::Twig>, L<version>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
=head1 SEE ALSO
+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<Test::LeakTrace>.
+
L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
=head1 AUTHOR
=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
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-2009 Vincent Pit, all rights reserved.
--- /dev/null
+package Test::Valgrind::Action;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Action - Base class for Test::Valgrind actions.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class is the base for L<Test::Valgrind> actions.
+
+Actions are called each time a tool encounter an error and decide what to do with it (for example passing or failing tests).
+
+=cut
+
+use base qw/Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+=head2 C<< new action => $action >>
+
+Creates a new action object of type C<$action> by requiring and redispatching the method call to the module named C<$action> if it contains C<'::'> or to C<Test::Valgrind::Action::$action> otherwise.
+The class represented by C<$action> must inherit this class.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ if ($class eq __PACKAGE__) {
+ my $action = delete $args{action} || 'Test';
+ $action =~ s/[^\w:]//g;
+ $action = __PACKAGE__ . "::$action" if $action !~ /::/;
+ $class->_croak("Couldn't load action $action: $@")
+ unless eval "require $action; 1";
+ return $action->new(%args);
+ }
+
+ my $self = bless { }, $class;
+
+ $self->started(undef);
+
+ $self;
+}
+
+=head2 C<do_suppressions>
+
+Indicates if the action wants C<valgrind> to run in suppression-generating mode or in analysis mode.
+
+=cut
+
+sub do_suppressions { 0 }
+
+=head2 C<started>
+
+Specifies whether the action is running (C<1>), stopped (C<0>) or was never started (C<undef>).
+
+=cut
+
+sub started { @_ <= 1 ? $_[0]->{started} : ($_[0]->{started} = $_[1]) }
+
+=head2 C<start $session>
+
+Called when the C<$session> starts.
+
+Defaults to set L</started>.
+
+=cut
+
+sub start {
+ my ($self) = @_;
+
+ $self->_croak('Action already started') if $self->started;
+ $self->started(1);
+
+ return;
+}
+
+=head2 C<report $session, $report>
+
+Invoked each time the C<valgrind> process attached to the C<$session> spots an error.
+C<$report> is a L<Test::Valgrind::Report> object describing the error.
+
+Defaults to check L</started>.
+
+=cut
+
+sub report {
+ my ($self) = @_;
+
+ $self->_croak('Action isn\'t started') unless $self->started;
+
+ return;
+}
+
+=head2 C<abort $session, $msg>
+
+Triggered when the C<$session> has to interrupt the action.
+
+Defaults to croak.
+
+=cut
+
+sub abort { $_[0]->_croak($_[2]) }
+
+=head2 C<finish $session>
+
+Called when the C<$session> finishes.
+
+Defaults to clear L</started>.
+
+=cut
+
+sub finish {
+ my ($self) = @_;
+
+ return unless $self->started;
+ $self->started(0);
+
+ return;
+}
+
+=head2 C<status $session>
+
+Returns the status code corresponding to the last run of the action.
+
+=cut
+
+sub status {
+ my ($self, $sess) = @_;
+
+ my $started = $self->started;
+
+ $self->_croak("Action was never started") unless defined $started;
+ $self->_croak("Action is still running") if $started;
+
+ return;
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Session>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Action
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Action
--- /dev/null
+package Test::Valgrind::Action::Captor;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Action::Captor - Mock Test::Valgrind::Action for capturing output.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class provides helpers for saving, redirecting and restoring filehandles.
+
+It's not meant to be used directly as an action.
+
+=cut
+
+use File::Spec ();
+
+use base qw/Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+=head2 C<new>
+
+Just a croaking stub to remind you not to use this class as a real action.
+
+=cut
+
+sub new { shift->_croak('This mock action isn\'t meant to be used directly') }
+
+# Widely inspired from Capture::Tiny
+
+sub _redirect_fh {
+ open $_[1], $_[2], $_[3]
+ or $_[0]->_croak('open(' . fileno($_[1]) . ", '$_[2]', '$_[3]'): $!");
+}
+
+sub _dup_fh {
+ my $fd = fileno $_[3];
+ open $_[1], $_[2] . '&' . $fd
+ or $_[0]->_croak('open(' . fileno($_[1]) . ", '$_[2]&', $fd): $!");
+}
+
+=head2 C<save_fh $from, $mode [, $to ]>
+
+Save the original filehandle C<$from> opened with mode C<$mode>, and redirect it to C<$to> if it's defined or to F</dev/null> otherwise.
+
+=cut
+
+sub save_fh {
+ my ($self, $from, $mode, $to) = @_;
+
+ unless (defined fileno $from) {
+ $self->_redirect_fh($from, $mode, File::Spec->devnull);
+ push @{$self->{proxies}}, $from;
+ }
+
+ $self->_dup_fh(my $save, $mode, $from);
+ push @{$self->{saves}}, [ $save, $mode, $from ];
+
+ if ($to and ref $to eq 'GLOB') {
+ $self->_dup_fh($from, $mode, $to);
+ } else {
+ $self->_redirect_fh($from, $mode, defined $to ? $to : File::Spec->devnull);
+ }
+
+ return;
+}
+
+=head2 C<restore_all_fh>
+
+Restore all the filehandles that were saved with L</save_fh> to their original state.
+
+The redirections aren't closed.
+
+=cut
+
+sub restore_all_fh {
+ my ($self) = @_;
+
+ for (@{$self->{saves}}) {
+ my ($save, $mode, $from) = @$_;
+ $self->_dup_fh($from, $mode, $save);
+ close $save or $self->_croak('close(saved[' . fileno($save) . "]): $!");
+ }
+ delete $self->{saves};
+
+ for (@{$self->{proxies}}) {
+ close $_ or $self->_croak('close(proxy[' . fileno($_) . "]): $!");
+ }
+ delete $self->{proxies};
+
+ return;
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Action>.
+
+L<Capture::Tiny>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Action::Captor
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Action::Captor
--- /dev/null
+package Test::Valgrind::Action::Suppressions;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Action::Suppressions - Generate suppressions for a given tool.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This action just writes the contents of the suppressions reports received into the suppression file.
+
+=cut
+
+use base qw/Test::Valgrind::Action Test::Valgrind::Action::Captor/;
+
+=head1 METHODS
+
+This class inherits L<Test::Valgrind::Action>.
+
+=head2 C<< new name => $name, target => $target, ... >>
+
+Your usual constructor.
+
+You need to specify the suppression prefix as the value of C<name>, and the target file as C<target>.
+
+Other arguments are passed straight to C<< Test::Valgrind::Action->new >>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my %validated;
+
+ for (qw/name target/) {
+ my $arg = delete $args{$_};
+ $class->_croak("'$_' is expected to be a plain scalar")
+ unless $arg and not ref $arg;
+ $validated{$_} = $arg;
+ }
+
+ my $self = $class->SUPER::new(%args);
+
+ $self->{$_} = $validated{$_} for qw/name target/;
+
+ $self;
+}
+
+sub do_suppressions { 1 }
+
+=head2 C<name>
+
+Read-only accessor for the C<name> option.
+
+=cut
+
+sub name { $_[0]->{name} }
+
+=head2 C<target>
+
+Read-only accessor for the C<target> option.
+
+=cut
+
+sub target { $_[0]->{target} }
+
+sub start {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::start($sess);
+
+ $self->{status} = undef;
+ $self->{total} = 0;
+ delete $self->{diagnostics};
+
+ if ($self->{fh}) {
+ close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
+ }
+
+ my $target = $self->target;
+
+ require File::Spec;
+ my ($vol, $dir, $file) = File::Spec->splitpath($target);
+ my $base = File::Spec->catpath($vol, $dir, '');
+ unless (-e $base) {
+ require File::Path;
+ File::Path::mkpath([ $base ]);
+ } else {
+ 1 while unlink $target;
+ }
+
+ open $self->{fh}, '>', $target
+ or $self->_croak("open(\$self->{fh}, '>', \$self->target): $!");
+
+ $self->save_fh(\*STDOUT => '>' => undef);
+ $self->save_fh(\*STDERR => '>' => undef);
+
+ return;
+}
+
+sub abort {
+ my $self = shift;
+
+ $self->restore_all_fh;
+
+ print $self->{diagnostics} if defined $self->{diagnostics};
+ delete $self->{diagnostics};
+
+ $self->{status} = 255;
+
+ $self->SUPER::abort(@_);
+}
+
+sub report {
+ my ($self, $sess, $report) = @_;
+
+ if ($report->is_diag) {
+ my $data = $report->data;
+ 1 while chomp $data;
+ $self->{diagnostics} .= "$data\n";
+ return;
+ }
+
+ $self->SUPER::report($sess, $report);
+
+ ++$self->{total};
+
+ print { $self->{fh} } "{\n"
+ . $self->name . $report->id . "\n"
+ . $report->data
+ . "}\n";
+
+ return;
+}
+
+sub finish {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::finish($sess);
+
+ $self->restore_all_fh;
+
+ close $self->{fh} or $self->_croak("close(\$self->{fh}): $!");
+
+ print $self->{diagnostics} if defined $self->{diagnostics};
+ delete $self->{diagnostics};
+ print "Found $self->{total} distinct suppressions\n";
+
+ $self->{status} = 0;
+
+ return;
+}
+
+sub status { $_[0]->{status} }
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Action>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Action::Suppressions
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Action::Supressions
--- /dev/null
+package Test::Valgrind::Action::Test;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Action::Test - Test that an analysis didn't generate any error report.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This action uses C<Test::Builder> to plan and pass or fail tests according to the reports received.
+
+=cut
+
+use Test::Builder;
+
+use base qw/Test::Valgrind::Action Test::Valgrind::Action::Captor/;
+
+=head1 METHODS
+
+This class inherits L<Test::Valgrind::Action> and L<Test::Valgrind::Action::Captor>.
+
+=head2 C<< new diag => $diag, extra_tests => $extra_tests, ... >>
+
+Your usual constructor.
+
+When C<$diag> is true, the original output of the command and the error reports are intermixed as diagnostics.
+
+C<$extra_tests> specifies how many extraneous tests you want to plan in addition to the default ones.
+
+Other arguments are passed straight to C<< Test::Valgrind::Action->new >>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my $diag = delete $args{diag};
+ my $extra_tests = delete $args{extra_tests} || 0;
+
+ my $self = bless $class->SUPER::new(%args), $class;
+
+ $self->{diag} = $diag;
+ $self->{extra_tests} = $extra_tests;
+
+ $self;
+}
+
+=head2 C<diag>
+
+Read-only accessor for the C<diag> option.
+
+=cut
+
+sub diag { $_[0]->{diag} }
+
+=head2 C<kinds>
+
+Returns the list of all the monitored report kinds.
+
+=cut
+
+sub kinds { @{$_[0]->{kinds} || []} }
+
+sub start {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::start($sess);
+
+ my @kinds = grep $_ ne 'Diag', $sess->report_class->kinds;
+ $self->{kinds} = \@kinds;
+ $self->{status} = 0;
+
+ my $tb = Test::Builder->new;
+
+ $tb->plan(tests => $self->{extra_tests} + scalar @kinds);
+
+ $self->restore_all_fh;
+
+ delete $self->{capture};
+ if ($self->diag) {
+ require File::Temp;
+ $self->{capture} = File::Temp::tempfile();
+ $self->{capture_pos} = 0;
+ }
+
+ $self->save_fh(\*STDOUT => '>' => $self->{capture});
+ $self->save_fh(\*STDERR => '>' => $self->{capture});
+
+ return;
+}
+
+sub abort {
+ my ($self, $sess, $msg) = @_;
+
+ $self->restore_all_fh;
+
+ my $tb = Test::Builder->new;
+ my $plan = $tb->has_plan;
+ if (defined $plan) {
+ $tb->BAIL_OUT($@);
+ $self->{status} = 255;
+ } else {
+ $tb->skip_all($@);
+ $self->{status} = 0;
+ }
+
+ return;
+}
+
+sub report {
+ my ($self, $sess, $report) = @_;
+
+ if ($report->is_diag) {
+ my $tb = Test::Builder->new;
+ $tb->diag($report->data);
+ return;
+ }
+
+ $self->SUPER::report($sess, $report);
+
+ $self->{reports}->{$report->kind}->{$report->id} = $report;
+
+ if ($self->diag) {
+ my $tb = Test::Builder->new;
+ my $fh = $self->{capture};
+ seek $fh, $self->{capture_pos}, 0;
+ $tb->diag($_) while <$fh>;
+ $self->{capture_pos} = tell $fh;
+ $tb->diag($report->dump);
+ }
+
+ return;
+}
+
+sub finish {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::finish($sess);
+
+ my $tb = Test::Builder->new;
+
+ $self->restore_all_fh;
+
+ if (my $fh = $self->{capture}) {
+ seek $fh, $self->{capture_pos}, 0;
+ $tb->diag($_) while <$fh>;
+ close $fh or $self->_croak('close(capture[' . fileno($fh) . "]): $!");
+ delete @{$self}{qw/capture capture_pos/};
+ }
+
+ my $failed = 0;
+
+ for my $kind ($self->kinds) {
+ my $reports = $self->{reports}->{$kind} || { };
+ my $errors = keys %$reports;
+ $tb->is_num($errors, 0, $kind);
+ if ($errors) {
+ ++$failed;
+ unless ($self->diag) {
+ $tb->diag("\n" . $_->dump) for values %$reports;
+ }
+ }
+ }
+
+ $self->{status} = $failed < 255 ? $failed : 254;
+
+ return;
+}
+
+sub status {
+ my ($self, $sess) = @_;
+
+ $self->SUPER::status($sess);
+
+ $self->{status};
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Action>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Action::Test
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Action::Test
--- /dev/null
+package Test::Valgrind::Carp;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Carp - Carp-like private methods for Test::Valgrind objects.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+sub _croak {
+ shift;
+ require Carp;
+ local $Carp::CarpLevel = ($Carp::CarpLevel || 0) + 1;
+ Carp::croak(@_);
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Carp
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Carp
--- /dev/null
+package Test::Valgrind::Command;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Command - Base class for Test::Valgrind commands.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class is the base for L<Test::Valgrind> commands.
+
+Commands gather information about the target of the analysis. They should also provide a default setup for generating suppressions.
+
+=cut
+
+use base qw/Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+=head2 C<< new command => $command, args => \@args >>
+
+Creates a new command object of type C<$command> by requiring and redispatching the method call to the module named C<$command> if it contains C<'::'> or to C<Test::Valgrind::Command::$command> otherwise.
+The class represented by C<$command> must inherit this class.
+
+The C<args> key is used to initialize the L</args> accessor.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ if ($class eq __PACKAGE__ and my $cmd = delete $args{command}) {
+ $cmd =~ s/[^\w:]//g;
+ $cmd = __PACKAGE__ . "::$cmd" if $cmd !~ /::/;
+ $class->_croak("Couldn't load command $cmd: $@") unless eval "require $cmd;1";
+ return $cmd->new(%args);
+ }
+
+ my $args = delete $args{args};
+ $class->_croak('Invalid argument list') unless $args and ref $args eq 'ARRAY';
+
+ bless {
+ args => $args,
+ }, $class;
+}
+
+=head2 C<new_trainer>
+
+Creates a new command object suitable for generating suppressions.
+
+Defaults to return C<undef>, which skips suppression generation.
+
+=cut
+
+sub new_trainer { }
+
+=head2 C<args $session>
+
+Returns the list of command-specific arguments that are to be passed to C<valgrind>.
+
+Defaults to return the contents of the C<args> option.
+
+=cut
+
+sub args { @{$_[0]->{args} || []} }
+
+=head2 C<env $session>
+
+This event is called in scalar context before the command is ran, and the returned value goes out of scope when the analysis ends.
+It's useful for e.g. setting up C<%ENV> for the child process by returning an L<Env::Sanctify> object, hence the name.
+
+Defaults to void.
+
+=cut
+
+sub env { }
+
+=head2 C<suppressions_tag $session>
+
+Returns a identifier that will be used to pick up the right suppressions for running the command, or C<undef> to indicate that no special suppressions are needed.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub suppressions_tag;
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Session>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Command
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # Test::Valgrind::Command
--- /dev/null
+package Test::Valgrind::Command::Perl;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+=cut
+
+use Env::Sanctify ();
+
+use base qw/Test::Valgrind::Command Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+This class inherits L<Test::Valgrind::Command>.
+
+=head2 C<< new perl => $^X, inc => \@INC, ... >>
+
+Your usual constructor.
+
+The C<perl> option specifies which C<perl> executable will run the arugment list given in C<args>.
+It defaults to C<$^X>.
+
+C<inc> is a reference to an array of paths that will be passed as C<-I> to the invoked command.
+It defaults to C<@INC>.
+
+Other arguments are passed straight to C<< Test::Valgrind::Command->new >>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my $perl = delete($args{perl}) || $^X;
+ my $inc = delete($args{inc}) || [ @INC ];
+ $class->_croak('Invalid INC list') unless ref $inc eq 'ARRAY';
+
+ my $trainer_file = delete $args{trainer_file};
+
+ my $self = bless $class->SUPER::new(%args), $class;
+
+ $self->{perl} = $perl;
+ $self->{inc} = $inc;
+ $self->{trainer_file} = $trainer_file;
+
+ return $self;
+}
+
+sub new_trainer {
+ my $self = shift;
+
+ require File::Temp;
+ my ($fh, $file) = File::Temp::tempfile(UNLINK => 0);
+ {
+ my $curpos = tell DATA;
+ print $fh $_ while <DATA>;
+ seek DATA, $curpos, 0;
+ }
+ close $fh or $self->_croak("close(tempscript): $!");
+
+ $self->new(
+ args => [ '-MTest::Valgrind=run,1', $file ],
+ trainer_file => $file,
+ @_
+ );
+}
+
+=head2 C<perl>
+
+Read-only accessor for the C<perl> option.
+
+=cut
+
+sub perl { $_[0]->{perl} }
+
+=head2 C<inc>
+
+Read-only accessor for the C<inc> option.
+
+=cut
+
+sub inc { @{$_[0]->{inc} || []} }
+
+sub args {
+ my $self = shift;
+
+ return $self->perl,
+ map("-I$_", $self->inc),
+ $self->SUPER::args(@_);
+}
+
+=head2 C<env $session>
+
+Returns an L<Env::Sanctify> object that sets the environment variables C<PERL_DESTRUCT_LEVEL> to C<3> and C<PERL_DL_NONLAZY> to C<1> during the run.
+
+=cut
+
+sub env {
+ Env::Sanctify->sanctify(
+ env => {
+ PERL_DESTRUCT_LEVEL => 2,
+ PERL_DL_NONLAZY => 1,
+ },
+ );
+}
+
+sub suppressions_tag {
+ my ($self) = @_;
+
+ unless (defined $self->{suppressions_tag}) {
+ my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]);
+
+ open my $pipe, '-|', $self->perl, '-V'
+ or $self->_croak('open("-| ' . $self->perl . " -V\"): $!");
+ my $perl_v = do { local $/; <$pipe> };
+ close $pipe or $self->_croak('close("-| ' . $self->perl . " -V\"): $!");
+
+ require Digest::MD5;
+ $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v);
+ }
+
+ return $self->{suppressions_tag};
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ my $file = $self->{trainer_file};
+ return unless $file and -e $file;
+
+ 1 while unlink $file;
+
+ return;
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Command>.
+
+L<Env::Sanctify>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Command::Perl
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Command::Perl
+
+__DATA__
+use strict;
+use warnings;
+
+BEGIN { require Test::Valgrind; }
+
+use Test::More;
+
+eval {
+ require XSLoader;
+ XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
+};
+
+unless ($@) {
+ Test::Valgrind::notleak("valgrind it!");
+} else {
+ diag $@;
+ *Test::Valgrind::DEBUGGING = sub { 'unknown' };
+}
+
+plan tests => 1;
+fail 'should not be seen';
+diag 'debbugging flag is ' . Test::Valgrind::DEBUGGING();
+
+eval {
+ require XSLoader;
+ XSLoader::load('Test::Valgrind::Fake', 0);
+};
+
+diag $@ ? 'Ok' : 'Succeeded to load Test::Valgrind::Fake but should\'t';
+
+require List::Util;
+
+my @cards = List::Util::shuffle(0 .. 51);
+
+{
+ package Test::Valgrind::Test::Fake;
+
+ use base qw/strict/;
+}
+
+eval 'use Time::HiRes qw/usleep/';
--- /dev/null
+package Test::Valgrind::Report;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Report - Base class for Test::Valgrind error reports.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+use base qw/Test::Valgrind::Carp/;
+
+=head2 C<< new kind => $kind, id => $id, data => $data >>
+
+Your usual constructor.
+
+All options are mandatory :
+
+=over 4
+
+=item *
+
+C<kind> is the category of the report.
+
+=item *
+
+C<id> is an unique identifier for the report.
+
+=item *
+
+C<data> is the content.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my $kind = delete $args{kind};
+ $class->_croak("Invalid kind $kind for $class")
+ unless $class->valid_kind($kind);
+
+ my $id = delete $args{id};
+ $class->_croak("Invalid identifier $id") unless defined $id and not ref $id;
+
+ my $data = delete $args{data};
+
+ bless {
+ kind => $kind,
+ id => $id,
+ data => $data,
+ }, $class;
+}
+
+=head2 C<< new_diag $data >>
+
+Constructs an object with kind C<'Diag'>, an auto-incremented identifier and the given C<$data>.
+
+=cut
+
+my $diag_id = 0;
+
+sub new_diag { shift->new(kind => 'Diag', id => ++$diag_id, data => $_[0]) }
+
+=head2 C<kind>
+
+Read-only accessor for the C<kind> option.
+
+=cut
+
+sub kind { $_[0]->{kind} }
+
+=head2 C<id>
+
+Read-only accessor for the C<id> option.
+
+=cut
+
+sub id { $_[0]->{id} }
+
+=head2 C<data>
+
+Read-only accessor for the C<data> option.
+
+=cut
+
+sub data { $_[0]->{data} }
+
+=head2 C<is_diag>
+
+Tells if a report has the C<'Diag'> kind, i.e. is a diagnostic.
+
+=cut
+
+sub is_diag { $_[0]->kind eq 'Diag' }
+
+=head2 C<kinds>
+
+Returns the list of valid kinds for this report class.
+
+Defaults to C<'Diag'>.
+
+=cut
+
+sub kinds { 'Diag' }
+
+=head2 C<valid_kind $kind>
+
+Tells whether C<$kind> is a valid kind for this report class.
+
+Defaults to true iff C<$kind eq 'Diag'>.
+
+=cut
+
+sub valid_kind { $_[1] eq 'Diag' }
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Report
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Report
--- /dev/null
+package Test::Valgrind::Session;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Session - Test::Valgrind session object.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class supervises the execution of the C<valgrind> process.
+It also acts as a dispatcher between the different components.
+
+=cut
+
+# All these modules are required at configure time.
+
+BEGIN {
+ require File::Spec;
+ require Scalar::Util;
+
+ require Fcntl; # F_SETFD
+ require POSIX; # SIGKILL
+
+ require version;
+}
+
+use base qw/Test::Valgrind::Carp/;
+
+use Test::Valgrind::Report;
+
+=head1 METHODS
+
+=head2 C<< new search_dirs => \@search_dirs, valgrind => [ $valgrind | \@valgrind ], min_version => $min_version, no_def_supp => $no_def_supp, extra_supps => \@extra_supps >>
+
+The package constructor, which takes several options :
+
+=over 4
+
+=item *
+
+All the directories from C<@search_dirs> will have F<valgrind> appended to create a list of candidates for the C<valgrind> executable.
+
+Defaults to the current C<PATH> environment variable.
+
+=item *
+
+If a simple scalar C<$valgrind> is passed as the value to C<'valgrind'>, it will be the only candidate.
+C<@search_dirs> will then be ignored.
+
+If an array refernce C<\@valgrind> is passed, its values will be I<prepended> to the list of the candidates resulting from C<@search_dirs>.
+
+=item *
+
+C<$min_version> specifies the minimal C<valgrind> version required.
+The constructor will croak if it's not able to find an adequate C<valgrind> from the supplied candidates list and search path.
+
+Defaults to none.
+
+=item *
+
+If C<$no_def_supp> is false, C<valgrind> won't read the default suppression file associated with the tool and the command.
+
+Defaults to false.
+
+=item *
+
+C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C<valgrind>.
+
+Defaults to none.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my @paths;
+ my $vg = delete $args{vg};
+ if (defined $vg and not ref $vg) {
+ @paths = ($vg);
+ } else {
+ push @paths, @$vg if $vg and ref $vg eq 'ARRAY';
+ my $dirs = delete $args{search_dirs};
+ $dirs = [ File::Spec->path ] unless $dirs;
+ push @paths, map File::Spec->catfile($_, 'valgrind'), @$dirs
+ if ref $dirs eq 'ARRAY';
+ }
+ $class->_croak('Empty valgrind candidates list') unless @paths;
+
+ my $min_version = delete $args{min_version};
+ defined and not ref and $_ = version->new($_) for $min_version;
+
+ my ($valgrind, $version);
+ for (@paths) {
+ next unless -x;
+ my $ver = qx/$_ --version/;
+ if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) {
+ $version = version->new($1);
+ next if $min_version and $version < $min_version;
+ $valgrind = $_;
+ last;
+ }
+ }
+ $class->_croak('No appropriate valgrind executable could be found')
+ unless defined $valgrind;
+
+ my $extra_supps = delete $args{extra_supps};
+ $extra_supps = [ ] unless $extra_supps and ref $extra_supps eq 'ARRAY';
+ @$extra_supps = grep { defined && -f $_ && -r _ } @$extra_supps;
+
+ bless {
+ valgrind => $valgrind,
+ version => $version,
+ no_def_supp => delete($args{no_def_supp}),
+ extra_supps => $extra_supps,
+ }, $class;
+}
+
+=head2 C<valgrind>
+
+The path to the selected C<valgrind> executable.
+
+=head2 C<version>
+
+The L<version> object associated to the selected C<valgrind>.
+
+=head2 C<no_def_supp>
+
+Read-only accessor for the C<no_def_supp> option.
+
+=cut
+
+eval "sub $_ { \$_[0]->{$_} }" for qw/valgrind version no_def_supp/;
+
+=head2 C<extra_supps>
+
+Read-only accessor for the C<extra_supps> option.
+
+=cut
+
+sub extra_supps { @{$_[0]->{extra_supps} || []} }
+
+=head2 C<< run action => $action, tool => $tool, command => $command >>
+
+Runs the command C<$command> through C<valgrind> with the tool C<$tool>, which will report to the action C<$action>.
+
+=cut
+
+sub run {
+ my $self = shift;
+
+ $self->start(@_);
+ my $guard = bless sub { $self->finish } => 'Test::Valgrind::Session::Guard';
+
+ $self->report(Test::Valgrind::Report->new_diag(
+ 'Using valgrind ' . $self->version . ' located at ' . $self->valgrind
+ ));
+
+ my $env = $self->command->env($self);
+
+ my @supp_args;
+ if ($self->do_suppressions) {
+ push @supp_args, '--gen-suppressions=all';
+ } else {
+ my @supps;
+ if (not $self->no_def_supp) {
+ my $def_supp = $self->def_supp_file;
+ if (defined $def_supp and not -e $def_supp) {
+ $self->report(Test::Valgrind::Report->new_diag("Generating suppressions..."));
+ require Test::Valgrind::Suppressions;
+ Test::Valgrind::Suppressions->generate(
+ tool => $self->tool,
+ command => $self->command,
+ target => $def_supp,
+ );
+ $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp;
+ $self->report(Test::Valgrind::Report->new_diag("Suppressions for this perl stored in $def_supp"));
+ }
+ }
+ push @supp_args, '--suppressions=' . $_ for $self->suppressions;
+ }
+
+ pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
+ {
+ my $oldfh = select $vrdr;
+ $|++;
+ select $oldfh;
+ }
+
+ my $pid = fork;
+ $self->_croak("fork(): $!") unless defined $pid;
+
+ if ($pid == 0) {
+ eval 'setpgrp 0, 0';
+ close $vrdr or $self->_croak("close(\$vrdr): $!");
+ fcntl $vwtr, Fcntl::F_SETFD(), 0
+ or $self->_croak("fcntl(\$vwtr, F_SETFD, 0): $!");
+
+ my @args = (
+ $self->valgrind,
+ '--log-fd=' . fileno($vwtr),
+ $self->tool->args($self),
+ @supp_args,
+ $self->command->args($self),
+ );
+
+# $self->report(Test::Valgrind::Report->new_diag("@args"));
+
+ exec { $args[0] } @args or $self->_croak("exec @args: $!");
+ }
+
+ local $SIG{INT} = sub {
+ kill -(POSIX::SIGKILL()) => $pid;
+ waitpid $pid, 0;
+ die 'interrupted';
+ };
+
+ close $vwtr or $self->_croak("close(\$vwtr): $!");
+
+ $self->tool->parse($self, $vrdr);
+
+ $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
+
+ close $vrdr or $self->_croak("close(\$vrdr): $!");
+
+ return;
+}
+
+sub Test::Valgrind::Session::Guard::DESTROY { $_[0]->() }
+
+=head2 C<action>
+
+Read-only accessor for the C<action> associated to the current run.
+
+=head2 C<tool>
+
+Read-only accessor for the C<tool> associated to the current run.
+
+=head2 C<command>
+
+Read-only accessor for the C<command> associated to the current run.
+
+=cut
+
+my @members;
+BEGIN {
+ @members = qw/action tool command/;
+ for (@members) {
+ eval "sub $_ { \@_ <= 1 ? \$_[0]->{$_} : (\$_[0]->{$_} = \$_[1]) }";
+ die if $@;
+ }
+}
+
+=head2 C<do_suppressions>
+
+Forwards to C<< ->action->do_suppressions >>.
+
+=cut
+
+sub do_suppressions { $_[0]->action->do_suppressions }
+
+=head2 C<report_class>
+
+Calls C<< ->action->report_class >> with the current session object as the sole argument.
+
+=cut
+
+sub report_class { $_[0]->tool->report_class($_[0]) }
+
+=head2 C<def_supp_file>
+
+Returns an absolute path to the default suppression file associated to the current session.
+C<undef> will be returned as soon as any of C<< ->tool->suppressions_tag >> or C<< ->tool->suppressions_tag >> are also C<undef>.
+Otherwise, the file part of the name is builded by joining those two together, and the directory part is roughly F<< File::HomeDir->my_home / .perl / Test-Valgrind / suppressions / $VERSION >>.
+
+=cut
+
+sub def_supp_file {
+ my ($self) = @_;
+
+ my $tool_tag = $self->tool->suppressions_tag($self);
+ return unless defined $tool_tag;
+
+ my $cmd_tag = $self->command->suppressions_tag($self);
+ return unless defined $cmd_tag;
+
+ require File::HomeDir; # So that it's not needed at configure time.
+
+ return File::Spec->catfile(
+ File::HomeDir->my_home,
+ '.perl',
+ 'Test-Valgrind',
+ 'suppressions',
+ $VERSION,
+ "$tool_tag-$cmd_tag.supp",
+ );
+}
+
+=head2 C<suppressions>
+
+Returns the list of all the suppressions that will be passed to C<valgrind>.
+Honors L</no_def_supp> and L</extra_supps>.
+
+=cut
+
+sub suppressions {
+ my ($self) = @_;
+
+ my @supps;
+ unless ($self->no_def_supp) {
+ my $def_supp = $self->def_supp_file;
+ push @supps, $def_supp if defined $def_supp;
+ }
+ push @supps, $self->extra_supps;
+
+ return @supps;
+}
+
+=head2 C<start>
+
+Starts the action and tool associated to the current run.
+It's automatically called at the beginning of L</run>.
+
+=cut
+
+sub start {
+ my $self = shift;
+
+ my %args = @_;
+
+ for (@members) {
+ my $base = 'Test::Valgrind::' . ucfirst;
+ my $value = $args{$_};
+ $self->_croak("Invalid $_") unless Scalar::Util::blessed($value)
+ and $value->isa($base);
+ $self->$_($args{$_})
+ }
+
+ delete @{$self}{qw/last_status exit_code/};
+
+ $self->tool->start($self);
+ $self->action->start($self);
+
+ return;
+}
+
+=head2 C<abort $msg>
+
+Forwards to C<< ->action->abort >> after unshifting the session object to the argument list.
+
+=cut
+
+sub abort {
+ my $self = shift;
+ $self->action->abort($self, @_);
+}
+
+=head2 C<report $report>
+
+Forwards to C<< ->action->report >> after unshifting the session object to the argument list.
+
+=cut
+
+sub report {
+ my $self = shift;
+ $self->action->report($self, @_);
+}
+
+=head2 C<finish>
+
+Finishes the action and tool associated to the current run.
+It's automatically called at the end of L</run>.
+
+=cut
+
+sub finish {
+ my ($self) = @_;
+
+ my $action = $self->action;
+ $action->finish($self);
+ $self->tool->finish($self);
+
+ my $status = $action->status($self);
+ $self->{last_status} = defined $status ? $status : $self->{exit_code};
+
+ $self->$_(undef) for @members;
+
+ return;
+}
+
+=head2 C<status>
+
+Returns the status code of the last run of the session.
+
+=cut
+
+sub status { $_[0]->{last_status} }
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Command>.
+
+L<version>, L<File::HomeDir>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Session
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Session
=head1 NAME
-Test::Valgrind::Suppressions - Placeholder for architecture-dependant perl suppressions.
+Test::Valgrind::Suppressions - Generate suppressions for given tool and command.
=head1 VERSION
-Version 0.08
+Version 1.00
=cut
-our $VERSION = '0.08';
+our $VERSION = '1.00';
=head1 DESCRIPTION
-L<Test::Valgrind> needs suppressions so that perl's errors aren't reported. However, these suppressions depend widely on the architecture, perl's version and the features it has been build with (e.g. threads). The goal of this module is hence to be installed together with the suppression file generated when the Test-Valgrind distribution was built, and to handle back to L<Test::Valgrind> the path to the suppression file.
-
-=head1 FUNCTIONS
-
-=head2 C<supp_path>
-
-Returns the path to the suppression file that applies to the current running perl, or C<undef> when no such file is available.
+This module is an helper for generating suppressions.
=cut
-sub supp_path {
- my $pkg = __PACKAGE__;
- $pkg =~ s!::!/!g;
- $pkg .= '.pm';
- return if not $INC{$pkg};
- my $supp = $INC{$pkg};
- $supp =~ s![^/]*$!perlTestValgrind.supp!;
- return (-f $supp) ? $supp : undef;
-}
-
-=head1 CONSTANTS
+use base qw/Test::Valgrind::Carp/;
-=head2 C<VG_PATH>
+=head1 METHODS
-The path to the valgrind binary from which the suppressions were generated.
+=head2 C<< generate tool => $tool, command => $command, target => $target >>
-=cut
-
-use constant VG_PATH => undef;
-
-=head1 EXPORT
+Generates suppressions for the command C<< $command->new_trainer >> and the tool C<< $tool->new_trainer >>, and writes them in the file specified by C<$target>.
+The action used behind the scenes is L<Test::Valgrind::Action::Suppressions>.
-This module exports the L</supp_path> function and the L</VG_PATH> constants only on demand, either by giving their name explicitely or by the C<:funcs>, C<:consts> or C<:all> tags.
+Returns the status code.
=cut
-use base qw/Exporter/;
-
-our @EXPORT = ();
-our %EXPORT_TAGS = (
- 'funcs' => [ qw/supp_path/ ],
- 'consts' => [ qw/VG_PATH/ ]
-);
-our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
-$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
+sub generate {
+ my $self = shift;
+
+ my %args = @_;
+
+ my $cmd = delete $args{command};
+ unless (ref $cmd) {
+ require Test::Valgrind::Command;
+ $cmd = Test::Valgrind::Command->new(
+ command => $cmd,
+ args => [ ],
+ );
+ }
+ $cmd = $cmd->new_trainer;
+ return unless defined $cmd;
+
+ my $tool = delete $args{tool};
+ unless (ref $tool) {
+ require Test::Valgrind::Tool;
+ $tool = Test::Valgrind::Tool->new(tool => $tool);
+ }
+ $tool = $tool->new_trainer;
+ return unless defined $tool;
+
+ my $target = delete $args{target};
+ $self->_croak('Invalid target') unless $target and not ref $target;
+
+ require Test::Valgrind::Action;
+ my $action = Test::Valgrind::Action->new(
+ action => 'Suppressions',
+ target => $target,
+ name => 'PerlSuppression',
+ );
+
+ require Test::Valgrind::Session;
+ my $sess = Test::Valgrind::Session->new(
+ min_version => $tool->requires_version,
+ );
+
+ eval {
+ $sess->run(
+ command => $cmd,
+ tool => $tool,
+ action => $action,
+ );
+ };
+ $self->_croak($@) if $@;
+
+ my $status = $sess->status;
+ $status = 255 unless defined $status;
+
+ return $status;
+}
=head1 SEE ALSO
-L<Test::Valgrind>.
+L<Test::Valgrind>, L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action::Suppressions>.
=head1 AUTHOR
=head1 BUGS
-Please report any bugs or feature requests to C<bug-test-valgrind-suppressions 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-suppressions 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
+++ /dev/null
-package Test::Valgrind::Suppressions;
-
-use strict;
-use warnings;
-
-=head1 NAME
-
-Test::Valgrind::Suppressions - Placeholder for architecture-dependant perl suppressions.
-
-=head1 VERSION
-
-Version 0.08
-
-=cut
-
-our $VERSION = '0.08';
-
-=head1 DESCRIPTION
-
-L<Test::Valgrind> needs suppressions so that perl's errors aren't reported. However, these suppressions depend widely on the architecture, perl's version and the features it has been build with (e.g. threads). The goal of this module is hence to be installed together with the suppression file generated when the Test-Valgrind distribution was built, and to handle back to L<Test::Valgrind> the path to the suppression file.
-
-=head1 FUNCTIONS
-
-=head2 C<supp_path>
-
-Returns the path to the suppression file that applies to the current running perl, or C<undef> when no such file is available.
-
-=cut
-
-sub supp_path {
- my $pkg = __PACKAGE__;
- $pkg =~ s!::!/!g;
- $pkg .= '.pm';
- return if not $INC{$pkg};
- my $supp = $INC{$pkg};
- $supp =~ s![^/]*$!perlTestValgrind.supp!;
- return (-f $supp) ? $supp : undef;
-}
-
-=head1 CONSTANTS
-
-=head2 C<VG_PATH>
-
-The path to the valgrind binary from which the suppressions were generated.
-
-=cut
-
-use constant VG_PATH => undef;
-
-=head1 EXPORT
-
-This module exports the L</supp_path> function and the L</VG_PATH> constants only on demand, either by giving their name explicitely or by the C<:funcs>, C<:consts> or C<:all> tags.
-
-=cut
-
-use base qw/Exporter/;
-
-our @EXPORT = ();
-our %EXPORT_TAGS = (
- 'funcs' => [ qw/supp_path/ ],
- 'consts' => [ qw/VG_PATH/ ]
-);
-our @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
-$EXPORT_TAGS{'all'} = [ @EXPORT_OK ];
-
-=head1 SEE ALSO
-
-L<Test::Valgrind>.
-
-=head1 AUTHOR
-
-Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
-
-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-suppressions 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
-
-You can find documentation for this module with the perldoc command.
-
- perldoc Test::Valgrind::Suppressions
-
-=head1 COPYRIGHT & LICENSE
-
-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.
-
-=cut
-
-1; # End of Test::Valgrind::Suppressions
--- /dev/null
+package Test::Valgrind::Tool;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Tool - Base class for Test::Valgrind tools.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class is the base for L<Test::Valgrind> tools.
+
+They wrap around C<valgrind> tools by parsing its output and sending reports to the parent session whenever an error occurs.
+They are expected to function both in suppressions generation and in analysis mode.
+
+=cut
+
+use base qw/Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+=head2 C<requires_version>
+
+The minimum C<valgrind> version needed to run this tool.
+Defaults to C<3.1.0>.
+
+=cut
+
+sub requires_version { '3.1.0' }
+
+=head2 C<< new tool => $tool >>
+
+Creates a new tool object of type C<$tool> by requiring and redispatching the method call to the module named C<$tool> if it contains C<'::'> or to C<Test::Valgrind::Tool::$tool> otherwise.
+The class represented by C<$tool> must inherit this class.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ if ($class eq __PACKAGE__) {
+ my $tool = delete $args{tool} || 'memcheck';
+ $tool =~ s/[^\w:]//g;
+ $tool = __PACKAGE__ . "::$tool" if $tool !~ /::/;
+ $class->_croak("Couldn't load tool $tool: $@") unless eval "require $tool; 1";
+ return $tool->new(%args);
+ }
+
+ bless { }, $class;
+}
+
+=head2 C<new_trainer>
+
+Creates a new tool object suitable for generating suppressions.
+
+Defaults to return C<undef>, which skips suppression generation.
+
+=cut
+
+sub new_trainer { }
+
+=head2 C<report_class $session>
+
+Wraps around either L</report_class_suppressions> or L</report_class_analysis> depending on the running mode of the C<$session>.
+
+=cut
+
+sub report_class {
+ my ($self, $sess) = @_;
+
+ if ($sess->do_suppressions) {
+ $self->report_class_suppressions($sess);
+ } else {
+ $self->report_class_analysis($sess);
+ }
+}
+
+=head2 C<report_class_suppressions $session>
+
+Returns the class in which suppression reports generated by this tool will be blessed.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub report_class_suppression;
+
+=head2 C<report_class_analysis $session>
+
+Returns the class in which error reports generated by this tool will be blessed.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub report_class_analysis;
+
+=head2 C<args $session>
+
+Returns the list of tool-specific arguments that are to be passed to C<valgrind>.
+All the suppression arguments are already handled by the session.
+
+Defaults to the empty list.
+
+=cut
+
+sub args { }
+
+=head2 C<suppressions_tag $session>
+
+Returns a identifier that will be used to pick up the right suppressions for running the tool, or C<undef> to indicate that no special suppressions are needed.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub suppressions_tag;
+
+=head2 C<start $session>
+
+Called when the C<$session> starts.
+
+Defaults to void.
+
+=cut
+
+sub start { }
+
+=head2 C<parse $session, $fh>
+
+Wraps around either L</parse_suppressions> or L</parse_analysis> depending on the running mode of the C<$session>.
+
+=cut
+
+sub parse {
+ my ($self, $sess, $fh) = @_;
+
+ if ($sess->do_suppressions) {
+ $self->parse_suppressions($sess, $fh);
+ } else {
+ $self->parse_analysis($sess, $fh);
+ }
+}
+
+=head2 C<parse_suppressions $sesssion, $fh>
+
+Parse the suppression reports sent by the C<valgrind> process attached to the session C<$session> through the filehandle C<$fh>.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub parse_suppressions;
+
+=head2 C<parse_analysis $sesssion, $fh>
+
+Parse the error reports sent by the C<valgrind> process attached to the session C<$session> through the filehandle C<$fh>.
+
+This method must be implemented when subclassing.
+
+=cut
+
+sub parse_analysis;
+
+=head2 C<finish $session>
+
+Called when the C<$session> finishes.
+
+Defaults to void.
+
+=cut
+
+sub finish { }
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Session>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Tool
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+1; # End of Test::Valgrind::Tool
--- /dev/null
+package Test::Valgrind::Tool::SuppressionsParser;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Tool::SuppressionsParser - Mock Test::Valgrind::Tool for parsing valgrind suppressions.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This class provides a default C<parse_suppressions> method, so that real tools for which suppressions are meaningful can exploit it by inheriting.
+
+It's not meant to be used directly as a tool.
+
+=cut
+
+use base qw/Test::Valgrind::Carp/;
+
+=head1 METHODS
+
+=head2 C<new>
+
+Just a croaking stub to remind you not to use this class as a real tool.
+
+If your tool both inherit from this class and from C<Test::Valgrind::Tool>, and that you want to dispatch the call to your C<new> to its ancestors', be careful with C<SUPER> which may end up calling this dieing version of C<new>.
+The solution is to either put C<Test::Valgrind::Tool> first in the C<@ISA> list or to explicitely call C<Test::Valgrind::Tool::new> instead of C<SUPER::new>.
+
+=cut
+
+sub new { shift->_croak('This mock tool isn\'t meant to be used directly') }
+
+=head2 C<report_class_suppressions $session>
+
+Generated reports are L<Test::Valgrind::Report::Suppressions> objects.
+Their C<data> member contains the raw text of the suppression.
+
+=cut
+
+sub report_class_suppressions { 'Test::Valgrind::Report::Suppressions' }
+
+=head2 C<parse_suppressions $session, $fh>
+
+Parses the filehandle C<$fh> fed with the output of F<valgrind --gen-suppressions=all> and sends a report to the session C<$session> for each suppression.
+
+=cut
+
+sub parse_suppressions {
+ my ($self, $sess, $fh) = @_;
+
+ my ($s, $in) = ('', 0);
+ my @supps;
+
+ while (<$fh>) {
+ s/^\s*#\s//;
+ next if /^==/;
+ next if /valgrind/; # and /\Q$file\E/;
+ s/^\s*//;
+ s/<[^>]+>//;
+ s/\s*$//;
+ next unless length;
+ if ($_ eq '{') {
+ $in = 1;
+ } elsif ($_ eq '}') {
+ my $unknown_tail;
+ ++$unknown_tail while $s =~ s/(\n)\s*obj:\*\s*$/$1/;
+ $s .= "...\n" if $unknown_tail and $sess->version ge '3.4.0';
+ push @supps, $s;
+ $s = '';
+ $in = 0;
+ } elsif ($in) {
+ $s .= "$_\n";
+ }
+ }
+
+ my @extra;
+ for (@supps) {
+ if (/\bfun:(m|c|re)alloc\b/) {
+ my $t = $1;
+ my %call;
+ if ($t eq 'm') { # malloc can also be called by calloc or realloc
+ $call{$_} = 1 for qw/calloc realloc/;
+ } elsif ($t eq 're') { # realloc can also call malloc or free
+ $call{$_} = 0 for qw/malloc free/;
+ } elsif ($t eq 'c') { # calloc can also call malloc
+ $call{$_} = 0 for qw/malloc/;
+ }
+ my $c = $_;
+ for (keys %call) {
+ my $d = $c;
+ $d =~ s/\b(fun:${t}alloc)\b/$call{$_} ? "$1\nfun:$_" : "fun:$_\n$1"/e;
+ # Remove one line for each line added or valgrind will hate us
+ $d =~ s/\n(.+?)\s*$/\n/;
+ push @extra, $d;
+ }
+ }
+ }
+
+ my %dupes;
+ @dupes{@supps, @extra} = ();
+ @supps = keys %dupes;
+
+ my $num;
+ $sess->report($self->report_class($sess)->new(
+ id => ++$num,
+ kind => 'Suppression',
+ data => $_,
+ )) for @supps;
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Tool>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Tool::SuppressionsParser
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+# End of Test::Valgrind::Tool::SuppressionsParser
+
+package Test::Valgrind::Report::Suppressions;
+
+use base qw/Test::Valgrind::Report/;
+
+sub kinds { shift->SUPER::kinds(), 'Suppression' }
+
+sub valid_kind {
+ my ($self, $kind) = @_;
+
+ $self->SUPER::valid_kind($kind) or $kind eq 'Suppression'
+}
+
+1; # End of Test::Valgrind::Report::Suppressions
--- /dev/null
+package Test::Valgrind::Tool::memcheck;
+
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Valgrind::Tool::memcheck - Run an analysis through the memcheck tool.
+
+=head1 VERSION
+
+Version 1.00
+
+=cut
+
+our $VERSION = '1.00';
+
+=head1 DESCRIPTION
+
+This tool parses the XML output of a C<memcheck> run with L<XML::Twig>.
+
+=cut
+
+use base qw/Test::Valgrind::Tool::SuppressionsParser Test::Valgrind::Tool/;
+
+=head1 METHODS
+
+This class inherits L<Test::Valgrind::Tool> and L<Test::Valgrind::Tool::SuppressionsParser>.
+
+=head2 C<requires_version>
+
+This tool requires C<valgrind> C<3.1.0>.
+
+=cut
+
+sub requires_version { '3.1.0' }
+
+=head2 C<< new callers => $callers, ... >>
+
+Your usual constructor.
+
+C<$callers> specifies the number of stack frames to inspect for errors : the bigger you set it, the more granular the analysis is.
+
+Other arguments are passed straight to C<< Test::Valgrind::Tool->new >>.
+
+=cut
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+
+ my $callers = delete $args{callers} || 12;
+ $callers =~ s/\D//g;
+
+ my $self = bless $class->Test::Valgrind::Tool::new(%args), $class;
+
+ $self->{callers} = $callers;
+
+ $self->{twig} = Test::Valgrind::Tool::memcheck::Twig->new(tool => $self);
+
+ $self;
+}
+
+sub new_trainer { shift->new(callers => 50) }
+
+=head2 C<callers>
+
+Read-only accessor for the C<callers> option.
+
+=cut
+
+sub callers { $_[0]->{callers} }
+
+=head2 C<twig>
+
+Read-only accessor for the underlying L<XML::Twig> parser.
+
+=cut
+
+sub twig { $_[0]->{twig} }
+
+sub suppressions_tag { 'memcheck-' . $_[1]->version }
+
+=head2 C<report_class_analysis $session>
+
+This tool emits C<Test::Valgrind::Tool::memcheck::Report> object reports in analysis mode.
+
+=cut
+
+sub report_class_analysis { 'Test::Valgrind::Tool::memcheck::Report' }
+
+sub args {
+ my ($self, $sess) = @_;
+
+ my @args = (
+ '--tool=memcheck',
+ '--leak-check=full',
+ '--leak-resolution=high',
+ '--show-reachable=yes',
+ '--num-callers=' . $self->callers,
+ '--error-limit=yes',
+ );
+
+ unless ($sess->do_suppressions) {
+ push @args, '--track-origins=yes' if $sess->version ge '3.4.0';
+ push @args, '--xml=yes';
+ }
+
+ push @args, $self->SUPER::args();
+
+ return @args;
+}
+
+# We must store the session in ourselves because it's only possible to pass
+# arguments to XML::Twig objects by a global stash.
+
+sub _session { @_ <= 1 ? $_[0]->{_session} : ($_[0]->{_session} = $_[1]) }
+
+sub start {
+ my ($self, $sess) = @_;
+
+ $self->_croak('This memcheck tool can\'t be run in two sessions at once')
+ if $self->_session;
+
+ $self->SUPER::start($sess);
+ $self->_session($sess);
+
+ return;
+}
+
+sub parse_analysis {
+ my ($self, $sess, $fh) = @_;
+
+ my $twig = $self->twig;
+ $twig->parse($fh);
+ $twig->purge;
+
+ return;
+}
+
+sub finish {
+ my ($self, $sess) = @_;
+
+ $self->_session(undef);
+ $self->SUPER::start($sess);
+
+ return;
+}
+
+=head1 SEE ALSO
+
+L<Test::Valgrind>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Tool::SuppressionsParser>.
+
+L<XML::Twig>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+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.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Valgrind::Tool::memcheck
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 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.
+
+=cut
+
+# End of Test::Valgrind::Tool::memcheck
+
+package Test::Valgrind::Tool::memcheck::Report;
+
+use base qw/Test::Valgrind::Report/;
+
+use Config qw/%Config/;
+
+our $VERSION = '1.00';
+
+my @kinds = qw/
+ InvalidFree
+ MismatchedFree
+ InvalidRead
+ InvalidWrite
+ InvalidJump
+ Overlap
+ InvalidMemPool
+ UninitCondition
+ UninitValue
+ SyscallParam
+ ClientCheck
+ Leak_DefinitelyLost
+ Leak_IndirectlyLost
+ Leak_PossiblyLost
+ Leak_StillReachable
+/;
+push @kinds, __PACKAGE__->SUPER::kinds();
+
+my %kinds_hashed = map { $_ => 1 } @kinds;
+
+sub kinds { @kinds }
+
+sub valid_kind { exists $kinds_hashed{$_[1]} }
+
+sub is_leak { $_[0]->kind =~ /^Leak_/ ? 1 : '' }
+
+my $pad = 2 * ($Config{ptrsize} || 4);
+
+sub dump {
+ my ($self) = @_;
+
+ my $data = $self->data;
+
+ my $desc = '';
+
+ for ([ '', 2, 4 ], [ 'aux', 4, 6 ], [ 'orig', 4, 6 ]) {
+ my ($prefix, $wind, $sind) = @$_;
+
+ my ($what, $stack) = @{$data}{"${prefix}what", "${prefix}stack"};
+ next unless defined $what and defined $stack;
+
+ $_ = ' ' x $_ for $wind, $sind;
+
+ $desc .= "$wind$what\n";
+ for (@$stack) {
+ my ($ip, $obj, $fn, $dir, $file, $line) = map { (defined) ? $_ : '?' } @$_;
+ my $frame;
+ if ($fn eq '?' and $obj eq '?') {
+ $ip =~ s/^0x//g;
+ $ip = hex $ip;
+ $frame = sprintf "0x%0${pad}X", $ip;
+ } else {
+ $frame = sprintf '%s (%s) [%s:%s]', $fn, $obj, $file, $line;
+ }
+ $desc .= "$sind$frame\n";
+ }
+ }
+
+ return $desc;
+}
+
+# End of Test::Valgrind::Tool::memcheck::Report
+
+package Test::Valgrind::Tool::memcheck::Twig;
+
+our $VERSION = '1.00';
+
+use Scalar::Util;
+
+use base qw/XML::Twig Test::Valgrind::Carp/;
+
+BEGIN { XML::Twig->add_options('Stash'); }
+
+my %handlers = (
+ '/valgrindoutput/error' => \&handle_error,
+);
+
+sub new {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ my %args = @_;
+ my $stash = delete $args{stash} || { };
+
+ my $tool = delete $args{tool};
+ $class->_croak('Invalid tool') unless Scalar::Util::blessed($tool)
+ and $tool->isa('Test::Valgrind::Tool');
+ $stash->{tool} = $tool;
+
+ bless $class->XML::Twig::new(
+ elt_class => __PACKAGE__ . '::Elt',
+ stash => $stash,
+ twig_roots => { map { $_ => 1 } keys %handlers },
+ twig_handlers => { map { $_ => $handlers{$_} } keys %handlers },
+ ), $class;
+}
+
+sub stash { shift->{Stash} }
+
+sub handle_error {
+ my ($twig, $node) = @_;
+
+ my $id = $node->kid('unique')->text;
+ my $kind = $node->kid('kind')->text;
+
+ my $data;
+
+ $data->{what} = $node->kid('what')->text;
+ $data->{stack} = [ map $_->listify_frame,
+ $node->kid('stack')->children('frame') ];
+
+ for (qw/leakedbytes leakedblocks/) {
+ my $kid = $node->first_child($_);
+ next unless $kid;
+ $data->{$_} = int $kid->text;
+ }
+
+ if (my $auxwhat = $node->first_child('auxwhat')) {
+ if (my $stack = $auxwhat->next_sibling('stack')) {
+ $data->{auxstack} = [ map $_->listify_frame, $stack->children('frame') ];
+ }
+ $data->{auxwhat} = $auxwhat->text;
+ }
+
+ if (my $origin = $node->first_child('origin')) {
+ $data->{origwhat} = $origin->kid('what')->text;
+ $data->{origstack} = [ map $_->listify_frame,
+ $origin->kid('stack')->children('frame') ];
+ }
+
+ my $report = Test::Valgrind::Tool::memcheck::Report->new(
+ kind => $kind,
+ id => $id,
+ data => $data,
+ );
+
+ $twig->stash->{tool}->_session->report($report);
+
+ $twig->purge;
+}
+
+# End of Test::Valgrind::Tool::memcheck::Twig
+
+package Test::Valgrind::Tool::memcheck::Twig::Elt;
+
+our $VERSION = '1.00';
+
+BEGIN { require XML::Twig; }
+
+use base qw/XML::Twig::Elt Test::Valgrind::Carp/;
+
+sub kid {
+ my ($self, $what) = @_;
+ my $node = $self->first_child($what);
+ $self->_croak("Couldn't get first $what child node") unless $node;
+ return $node;
+}
+
+sub listify_frame {
+ my ($frame) = @_;
+
+ return unless $frame->tag eq 'frame';
+
+ return [
+ map {
+ my $x = $frame->first_child($_);
+ $x ? $x->text : undef
+ } qw/ip obj fn dir file line/
+ ];
+}
+
+1; # End of Test::Valgrind::Tool::memcheck::Twig::Elt
use strict;
use warnings;
-use lib qw{blib/lib blib/archpub};
+use lib 'blib/lib';
use Test::Valgrind;
{
local $SIG{ALRM} = sub { kill "TERM", $$ };
alarm 1;
- while (1) { map 1, 1 };
+ while (1) { map 1, 1 }
}
--- /dev/null
+
+As of May 2005, Valgrind can produce its output in XML form. The
+intention is to provide an easily parsed, stable format which is
+suitable for GUIs to read.
+
+
+Design goals
+~~~~~~~~~~~~
+
+* Produce XML output which is easily parsed
+
+* Have a stable output format which does not change much over time, so
+ that investments in parser-writing by GUI developers is not lost as
+ new versions of Valgrind appear.
+
+* Have an extensive output format, so that future changes to the
+ format do not break backwards compatibility with existing parsers of
+ it.
+
+* Produce output in a form which suitable for both offline GUIs (run
+ all the way to the end, then examine output) and interactive GUIs
+ (parse XML incrementally, update display as we go).
+
+* Put as much information as possible into the XML and let the GUIs
+ decide what to show the user (a.k.a provide mechanism, not policy).
+
+* Make XML which is actually parseable by standard XML tools.
+
+
+How to use
+~~~~~~~~~~
+
+Run with flag --xml=yes. That`s all. Note however several
+caveats.
+
+* At the present time only Memcheck is supported. The scheme extends
+ easily enough to cover Helgrind if needed.
+
+* When XML output is selected, various other settings are made.
+ This is in order that the output format is more controlled.
+ The settings which are changed are:
+
+ - Suppression generation is disabled, as that would require user
+ input.
+
+ - Attaching to GDB is disabled for the same reason.
+
+ - The verbosity level is set to 1 (-v).
+
+ - Error limits are disabled. Usually if the program generates a lot
+ of errors, Valgrind slows down and eventually stops collecting
+ them. When outputting XML this is not the case.
+
+ - VEX emulation warnings are not shown.
+
+ - File descriptor leak checking is disabled. This could be
+ re-enabled at some future point.
+
+ - Maximum-detail leak checking is selected (--leak-check=full).
+
+
+The output format
+~~~~~~~~~~~~~~~~~
+For the most part this should be self descriptive. It is printed in a
+sort-of human-readable way for easy understanding. You may want to
+read the rest of this together with the results of "valgrind --xml=yes
+memcheck/tests/xml1" as an example.
+
+All tags are balanced: a <foo> tag is always closed by </foo>. Hence
+in the description that follows, mention of a tag <foo> implicitly
+means there is a matching closing tag </foo>.
+
+Symbols in CAPITALS are nonterminals in the grammar and are defined
+somewhere below. The root nonterminal is TOPLEVEL.
+
+The following nonterminals are not described further:
+ INT is a 64-bit signed decimal integer.
+ TEXT is arbitrary text.
+ HEX64 is a 64-bit hexadecimal number, with leading "0x".
+
+Text strings are escaped so as to remove the <, > and & characters
+which would otherwise mess up parsing. They are replaced respectively
+with the standard encodings "<", ">" and "&" respectively.
+Note this is not (yet) done throughout, only for function names in
+<frame>..</frame> tags-pairs.
+
+
+TOPLEVEL
+--------
+
+The first line output is always this:
+
+ <?xml version="1.0"?>
+
+All remaining output is contained within the tag-pair
+<valgrindoutput>.
+
+Inside that, the first entity is an indication of the protocol
+version. This is provided so that existing parsers can identify XML
+created by future versions of Valgrind merely by observing that the
+protocol version is one they don`t understand. Hence TOPLEVEL is:
+
+ <?xml version="1.0"?>
+ <valgrindoutput>
+ <protocolversion>INT<protocolversion>
+ PROTOCOL
+ </valgrindoutput>
+
+Valgrind versions 3.0.0 and 3.0.1 emit protocol version 1. Versions
+3.1.X and 3.2.X emit protocol version 2. 3.4.X emits protocol version
+3.
+
+
+PROTOCOL for version 3
+----------------------
+Changes in 3.4.X (tentative): (jrs, 1 March 2008)
+
+* There may be more than one <logfilequalifier> clause.
+
+* Some errors may have two <auxwhat> blocks, rather than just one
+ (resulting from merge of the DATASYMS branch)
+
+* Some errors may have an ORIGIN component, indicating the origins of
+ uninitialised values. This results from the merge of the
+ OTRACK_BY_INSTRUMENTATION branch.
+
+
+PROTOCOL for version 2
+----------------------
+Version 2 is identical in every way to version 1, except that the time
+string in
+
+ <time>human-readable-time-string</time>
+
+has changed format, and is also elapsed wallclock time since process
+start, and not local time or any such. In fact version 1 does not
+define the format of the string so in some ways this revision is
+irrelevant.
+
+
+PROTOCOL for version 1
+----------------------
+This is the main top-level construction. Roughly speaking, it
+contains a load of preamble, the errors from the run of the
+program, and the result of the final leak check. Hence the
+following in sequence:
+
+* Various preamble lines which give version info for the various
+ components. The text in them can be anything; it is not intended
+ for interpretation by the GUI:
+
+ <preamble>
+ <line>Misc version/copyright text</line> (zero or more of)
+ </preamble>
+
+* The PID of this process and of its parent:
+
+ <pid>INT</pid>
+ <ppid>INT</ppid>
+
+* The name of the tool being used:
+
+ <tool>TEXT</tool>
+
+* OPTIONALLY, if --log-file-qualifier=VAR flag was given:
+
+ <logfilequalifier> <var>VAR</var> <value>$VAR</value>
+ </logfilequalifier>
+
+ That is, both the name of the environment variable and its value
+ are given.
+ [update: as of v3.3.0, this is not present, as the --log-file-qualifier
+ option has been removed, replaced by the %q format specifier in --log-file.]
+
+* OPTIONALLY, if --xml-user-comment=STRING was given:
+
+ <usercomment>STRING</usercomment>
+
+ STRING is not escaped in any way, so that it itself may be a piece
+ of XML with arbitrary tags etc.
+
+* The program and args: first those pertaining to Valgrind itself, and
+ then those pertaining to the program to be run under Valgrind (the
+ client):
+
+ <args>
+ <vargv>
+ <exe>TEXT</exe>
+ <arg>TEXT</arg> (zero or more of)
+ </vargv>
+ <argv>
+ <exe>TEXT</exe>
+ <arg>TEXT</arg> (zero or more of)
+ </argv>
+ </args>
+
+* The following, indicating that the program has now started:
+
+ <status> <state>RUNNING</state>
+ <time>human-readable-time-string</time>
+ </status>
+
+* Zero or more of (either ERROR or ERRORCOUNTS).
+
+* The following, indicating that the program has now finished, and
+ that the wrapup (leak checking) is happening.
+
+ <status> <state>FINISHED</state>
+ <time>human-readable-time-string</time>
+ </status>
+
+* SUPPCOUNTS, indicating how many times each suppression was used.
+
+* Zero or more ERRORs, each of which is a complaint from the
+ leak checker.
+
+That's it.
+
+
+ERROR
+-----
+This shows an error, and is the most complex nonterminal. The format
+is as follows:
+
+ <error>
+ <unique>HEX64</unique>
+ <tid>INT</tid>
+ <kind>KIND</kind>
+ <what>TEXT</what>
+
+ optionally: <leakedbytes>INT</leakedbytes>
+ optionally: <leakedblocks>INT</leakedblocks>
+
+ STACK
+
+ optionally: <auxwhat>TEXT</auxwhat>
+ optionally: STACK
+ optionally: ORIGIN
+
+ </error>
+
+* Each error contains a unique, arbitrary 64-bit hex number. This is
+ used to refer to the error in ERRORCOUNTS nonterminals (see below).
+
+* The <tid> tag indicates the Valgrind thread number. This value
+ is arbitrary but may be used to determine which threads produced
+ which errors (at least, the first instance of each error).
+
+* The <kind> tag specifies one of a small number of fixed error
+ types (enumerated below), so that GUIs may roughly categorise
+ errors by type if they want.
+
+* The <what> tag gives a human-understandable description of the
+ error.
+
+* For <kind> tags specifying a KIND of the form "Leak_*", the
+ optional <leakedbytes> and <leakedblocks> indicate the number of
+ bytes and blocks leaked by this error.
+
+* The primary STACK for this error, indicating where it occurred.
+
+* Some error types may have auxiliary information attached:
+
+ <auxwhat>TEXT</auxwhat> gives an auxiliary human-readable
+ description (usually of invalid addresses)
+
+ STACK gives an auxiliary stack (usually the allocation/free
+ point of a block). If this STACK is present then
+ <auxwhat>TEXT</auxwhat> will precede it.
+
+
+KIND
+----
+This is a small enumeration indicating roughly the nature of an error.
+The possible values are:
+
+ InvalidFree
+
+ free/delete/delete[] on an invalid pointer
+
+ MismatchedFree
+
+ free/delete/delete[] does not match allocation function
+ (eg doing new[] then free on the result)
+
+ InvalidRead
+
+ read of an invalid address
+
+ InvalidWrite
+
+ write of an invalid address
+
+ InvalidJump
+
+ jump to an invalid address
+
+ Overlap
+
+ args overlap other otherwise bogus in eg memcpy
+
+ InvalidMemPool
+
+ invalid mem pool specified in client request
+
+ UninitCondition
+
+ conditional jump/move depends on undefined value
+
+ UninitValue
+
+ other use of undefined value (primarily memory addresses)
+
+ SyscallParam
+
+ system call params are undefined or point to
+ undefined/unaddressible memory
+
+ ClientCheck
+
+ "error" resulting from a client check request
+
+ Leak_DefinitelyLost
+
+ memory leak; the referenced blocks are definitely lost
+
+ Leak_IndirectlyLost
+
+ memory leak; the referenced blocks are lost because all pointers
+ to them are also in leaked blocks
+
+ Leak_PossiblyLost
+
+ memory leak; only interior pointers to referenced blocks were
+ found
+
+ Leak_StillReachable
+
+ memory leak; pointers to un-freed blocks are still available
+
+
+STACK
+-----
+STACK indicates locations in the program being debugged. A STACK
+is one or more FRAMEs. The first is the innermost frame, the
+next its caller, etc.
+
+ <stack>
+ one or more FRAME
+ </stack>
+
+
+FRAME
+-----
+FRAME records a single program location:
+
+ <frame>
+ <ip>HEX64</ip>
+ optionally <obj>TEXT</obj>
+ optionally <fn>TEXT</fn>
+ optionally <dir>TEXT</dir>
+ optionally <file>TEXT</file>
+ optionally <line>INT</line>
+ </frame>
+
+Only the <ip> field is guaranteed to be present. It indicates a
+code ("instruction pointer") address.
+
+The optional fields, if present, appear in the order stated:
+
+* obj: gives the name of the ELF object containing the code address
+
+* fn: gives the name of the function containing the code address
+
+* dir: gives the source directory associated with the name specified
+ by <file>. Note the current implementation often does not
+ put anything useful in this field.
+
+* file: gives the name of the source file containing the code address
+
+* line: gives the line number in the source file
+
+
+ORIGIN
+------
+ORIGIN shows the origin of uninitialised data in errors that involve
+uninitialised data. STACK shows the origin of the uninitialised
+value. TEXT gives a human-understandable hint as to the meaning of
+the information in STACK.
+
+ <origin>
+ <what>TEXT<what>
+ STACK
+ </origin>
+
+
+ERRORCOUNTS
+-----------
+This specifies, for each error that has been so far presented,
+the number of occurrences of that error.
+
+ <errorcounts>
+ zero or more of
+ <pair> <count>INT</count> <unique>HEX64</unique> </pair>
+ </errorcounts>
+
+Each <pair> gives the current error count <count> for the error with
+unique tag </unique>. The counts do not have to give a count for each
+error so far presented - partial information is allowable.
+
+As at Valgrind rev 3793, error counts are only emitted at program
+termination. However, it is perfectly acceptable to periodically emit
+error counts as the program is running. Doing so would facilitate a
+GUI to dynamically update its error-count display as the program runs.
+
+
+SUPPCOUNTS
+----------
+A SUPPCOUNTS block appears exactly once, after the program terminates.
+It specifies the number of times each error-suppression was used.
+Suppressions not mentioned were used zero times.
+
+ <suppcounts>
+ zero or more of
+ <pair> <count>INT</count> <name>TEXT</name> </pair>
+ </suppcounts>
+
+The <name> is as specified in the suppression name fields in .supp
+files.
+
use Test::More tests => 1;
-use lib qw{blib/archpub};
BEGIN {
use_ok( 'Test::Valgrind::Suppressions' );
}
+++ /dev/null
-#!perl -T
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-use lib qw{blib/archpub};
-require Test::Valgrind::Suppressions;
-
-for (qw/supp_path VG_PATH/) {
- eval { Test::Valgrind::Suppressions->import($_) };
- ok(!$@, 'import ' . $_);
-}
use warnings;
use Test::More;
-use lib qw{blib/archpub};
+
+use lib 't/lib';
eval 'use Test::Valgrind';
if ($@) {
diag $@;
plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
}
+{
+ package Test::Valgrind::Test::Fake;
+
+ use base qw/strict/;
+}
+
plan tests => 1;
-fail('bogus failure, don\'t worry');
+fail 'should not be seen';
+++ /dev/null
-#!perl -T
-
-use strict;
-use warnings;
-use Test::More tests => 3;
-
-use lib qw{blib/archpub};
-use Test::Valgrind::Suppressions qw/supp_path VG_PATH/;
-
-my $path = supp_path();
-like($path, qr!Test/Valgrind/perlTestValgrind\.supp$!,
- 'supppath() returns the path to the suppression file');
-
-isnt(VG_PATH, undef, 'VG_PATH is defined');
-
-if (not open my $supp, '<', $path) {
- fail("Couldn't open the suppression file at $path: $!");
-} else {
- pass("Could open the suppression file");
- my ($in, $count, $true, $line) = (0, 0, 0, 0);
- while (<$supp>) {
- ++$line;
- chomp;
- s/^\s*//;
- s/\s*$//;
- if (!$in && $_ eq '{') {
- $in = $line;
- } elsif ($in && $_ eq '}') {
- ++$count;
- ++$true if $line - $in >= 2;
- $in = 0;
- }
- }
- diag "$count suppressions, of which $true are not empty";
- close $supp;
-}
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 't/lib';
+eval 'use Test::Valgrind action => q[Test::Valgrind::Test::Action]';
+if ($@) {
+ diag $@;
+ plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
+}
+
+eval {
+ require XSLoader;
+ XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
+};
+
+unless ($@) {
+ Test::Valgrind::leak();
+} else {
+ diag $@;
+}
+++ /dev/null
-#!perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-my $dbg;
-
-sub tester {
- my ($num, $desc) = @_;
- my $passed;
- if (!defined $dbg) {
- eval "
- use lib qw{blib/arch};
- require XSLoader;
- XSLoader::load('Test::Valgrind', \$Test::Valgrind::VERSION);
- ";
- if ($@) {
- my $err = $@;
- $dbg = 0;
- chomp $err;
- diag "XS test code not available ($err)";
- } else {
- my $ret = eval "Test::Valgrind::DEBUGGING()";
- $dbg = $@ ? 0 : $ret;
- }
- }
- if ($desc =~ /definitely\s+lost/) {
- $passed = $num >= 9900 && $num < 10100;
- if ($dbg) {
- ok($passed, $desc);
- diag " Got $num instead of 0." unless $passed;
- } else {
- TODO: {
- local $TODO = "Leak count may be off on non-debugging perls";
- ok($passed, $desc);
- }
- $passed = 1;
- }
- } else {
- $passed = defined $num && $num == 0;
- is($num, 0, $desc);
- }
- return $passed;
-}
-
-use lib qw{blib/archpub};
-eval 'use Test::Valgrind cb => \&tester';
-if ($@) {
- diag $@;
- plan skip_all => 'Test::Valgrind is required to run test your distribution with valgrind';
-} else {
- eval "
- use lib qw{blib/arch};
- require XSLoader;
- XSLoader::load('Test::Valgrind', \$Test::Valgrind::VERSION);
- ";
- unless ($@) {
- Test::Valgrind::leak();
- }
-}
--- /dev/null
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+
+use Test::Valgrind::Command;
+use Test::Valgrind::Tool;
+use Test::Valgrind::Action;
+use Test::Valgrind::Session;
+
+my $cmd = Test::Valgrind::Command->new(
+ command => 'Perl',
+ args => [ ],
+);
+
+my $tool = Test::Valgrind::Tool->new(
+ tool => 'memcheck',
+);
+
+my $sess = Test::Valgrind::Session->new(
+ min_version => $tool->requires_version,
+);
+
+$sess->command($cmd);
+$sess->tool($tool);
+
+my $file = $sess->def_supp_file;
+
+like($file, qr!\Q$Test::Valgrind::Session::VERSION\E/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!, 'suppression file is correctly named');
+ok(-e $file, 'suppression file exists');
+ok(-r $file, 'suppression file is readable');
+
+if (not open my $supp, '<', $file) {
+ fail("Couldn't open the suppression file at $file: $!");
+} else {
+ pass("Could open the suppression file");
+ my ($in, $count, $true, $line) = (0, 0, 0, 0);
+ while (<$supp>) {
+ ++$line;
+ chomp;
+ s/^\s*//;
+ s/\s*$//;
+ if (!$in && $_ eq '{') {
+ $in = $line;
+ } elsif ($in && $_ eq '}') {
+ ++$count;
+ ++$true if $line - $in >= 2;
+ $in = 0;
+ }
+ }
+ diag "$count suppressions, of which $true are not empty";
+ close $supp;
+}
+++ /dev/null
-#!perl -T
-
-use strict;
-use warnings;
-use Test::More tests => 4;
-
-sub not_in_file_ok {
- my ($filename, %regex) = @_;
- open( my $fh, '<', $filename )
- or die "couldn't open $filename for reading: $!";
-
- my %violated;
-
- while (my $line = <$fh>) {
- while (my ($desc, $regex) = each %regex) {
- if ($line =~ $regex) {
- push @{$violated{$desc}||=[]}, $.;
- }
- }
- }
-
- if (%violated) {
- fail("$filename contains boilerplate text");
- diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
- } else {
- pass("$filename contains no boilerplate text");
- }
-}
-
-sub module_boilerplate_ok {
- my ($module) = @_;
- not_in_file_ok($module =>
- 'the great new $MODULENAME' => qr/ - The great new /,
- 'boilerplate description' => qr/Quick summary of what the module/,
- 'stub function definition' => qr/function[12]/,
- );
-}
-
-not_in_file_ok(README =>
- "The README is used..." => qr/The README is used/,
- "'version information here'" => qr/to provide version information/,
-);
-
-not_in_file_ok(Changes =>
- "placeholder date/time" => qr(Date/time)
-);
-
-module_boilerplate_ok('lib/Test/Valgrind.pm');
-module_boilerplate_ok('lib/Test/Valgrind/Suppressions.pm');
use strict;
use warnings;
+
use Test::More;
# Ensure a recent version of Test::Pod
+#!perl -T
+
use strict;
use warnings;
+
use Test::More;
# Ensure a recent version of Test::Pod::Coverage
eval "use Pod::Coverage $min_pc";
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" if $@;
-plan tests => 1;
+my $trustparents = { coverage_class => 'Pod::Coverage::CountParents' };
+
+plan tests => 14;
+
pod_coverage_ok('Test::Valgrind');
+
+pod_coverage_ok('Test::Valgrind::Action');
+pod_coverage_ok('Test::Valgrind::Action::Captor');
+pod_coverage_ok('Test::Valgrind::Action::Suppressions', $trustparents);
+pod_coverage_ok('Test::Valgrind::Action::Test', $trustparents);
+
+pod_coverage_ok('Test::Valgrind::Carp');
+
+pod_coverage_ok('Test::Valgrind::Command');
+pod_coverage_ok('Test::Valgrind::Command::Perl', $trustparents);
+
+pod_coverage_ok('Test::Valgrind::Report');
+pod_coverage_ok('Test::Valgrind::Session');
+pod_coverage_ok('Test::Valgrind::Suppressions');
+
+pod_coverage_ok('Test::Valgrind::Tool');
+pod_coverage_ok('Test::Valgrind::Tool::SuppressionsParser');
+pod_coverage_ok('Test::Valgrind::Tool::memcheck', $trustparents);
--- /dev/null
+package Test::Valgrind::Test::Action;
+
+use strict;
+use warnings;
+
+use base qw/Test::Valgrind::Action::Test/;
+
+my $extra_tests;
+
+BEGIN {
+ eval {
+ require Test::Valgrind;
+ require XSLoader;
+ XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
+ };
+ if ($@) {
+ $extra_tests = 0;
+ } else {
+ $extra_tests = 2;
+ *report = *report_smart;
+ }
+}
+
+use Test::Builder;
+
+sub new { shift->SUPER::new(extra_tests => $extra_tests) }
+
+sub report_smart {
+ my ($self, $sess, $report) = @_;
+
+ if ($report->can('is_leak') and $report->is_leak) {
+ my $tb = Test::Builder->new;
+ my $data = $report->data;
+ $tb->is_eq($data->{leakedbytes}, 10_000, '10_000 bytes leaked');
+ $tb->is_eq($data->{leakedblocks}, 1, ' in one block');
+ $tb->diag("The subsequent report was correctly caught:\n" . $report->dump)
+ if ($data->{leakedbytes} || 0) == 10_000
+ and ($data->{leakedblocks} || 0) == 1;
+ return;
+ }
+
+ $self->SUPER::report($sess, $report);
+}
+
+1;
projects / perl / modules / Test-Valgrind.git / commitdiff