X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind.pm;h=5e95a9fffb87ed30cc37ce0752eba1cbf54b7fae;hb=b354437c7e018fdd1861e90a58f1f639c6bcf047;hp=e8925d86cdd19523f96a363bc09a446379a521f9;hpb=1a45e7f9e0b3b355dbfe3a3e70d638880aa2b264;p=perl%2Fmodules%2FTest-Valgrind.git diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm index e8925d8..5e95a9f 100644 --- a/lib/Test/Valgrind.pm +++ b/lib/Test/Valgrind.pm @@ -3,240 +3,342 @@ package Test::Valgrind; use strict; use warnings; -use Carp qw/croak/; -use POSIX qw/SIGTERM/; -use Test::More; - -use Perl::Destruct::Level level => 3; - -use Test::Valgrind::Suppressions; - =head1 NAME -Test::Valgrind - Test Perl code through valgrind. +Test::Valgrind - Generate suppressions, analyse and test any command with valgrind. =head1 VERSION -Version 0.051 +Version 1.14 =cut -our $VERSION = '0.051'; +our $VERSION = '1.14'; =head1 SYNOPSIS + # From the command-line + perl -MTest::Valgrind leaky.pl + + # From the command-line, snippet style + perl -MTest::Valgrind -e 'leaky()' + + # In a test file use Test::More; eval 'use Test::Valgrind'; plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@; + leaky(); - # Code to inspect for memory leaks/errors. + # In all the test files of a directory + prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t =head1 DESCRIPTION -This module lets you run some code through the B memory debugger, to test it for memory errors and leaks. Just add C at the beginning of the code you want to test. Behind the hood, C forks so that the child can basically C (except that of course C<$0> isn't right there). The parent then parses the report output by valgrind and pass or fail tests accordingly. +This module is a front-end to the C API that lets you run Perl code through the C tool of the C memory debugger, to test for memory errors and leaks. +If they aren't available yet, it will first generate suppressions for the current C interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>. +The actual run will then take place, and tests will be passed or failed according to the result of the analysis. -You can also use it from the command-line to test a given script : +The complete API is much more versatile than this. +By declaring an appropriate L class, you can run any executable (that is, not only Perl scripts) under valgrind, generate the corresponding suppressions on-the-fly and convert the analysis result to TAP output so that it can be incorporated into your project's testsuite. +If you're not interested in producing TAP, you can output the results in whatever format you like (for example HTML pages) by defining your own L class. - perl -MTest::Valgrind leaky.pl +Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects. +This includes non-mortalized scalars and memory cycles. +However, it can track leaks of chunks of memory allocated in XS extensions with C and friends or C. +As such, it's complementary to the other very good leak detectors listed in the L 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 and friends or C. As such, it's complementary to the other very good leak detectors listed in the L section. +=head1 METHODS -=head1 CONFIGURATION +=head2 C -You can pass parameters to C as a list of key / value pairs, where valid keys are : + Test::Valgrind->analyse(%options); + +Run a C analysis configured by C<%options> : =over 4 =item * -C<< supp => $file >> +C<< command => $command >> + +The L object (or class name) to use. -Also use suppressions from C<$file> besides perl's. +Defaults to L. =item * -C<< no_supp => $bool >> +C<< tool => $tool >> + +The L object (or class name) to use. -If true, do not use any suppressions. +Defaults to L. =item * -C<< callers => $number >> +C<< action => $action >> + +The L object (or class name) to use. + +Defaults to L. -Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12. +=item * + +C<< file => $file >> + +The file name of the script to analyse. + +Ignored if you supply your own custom C, but mandatory otherwise. =item * -C<< extra => [ @args ] >> +C<< callers => $number >> + +Specify the maximum stack depth studied when valgrind encounters an error. +Raising this number improves granularity. -Add C<@args> to valgrind parameters. +Ignored if you supply your own custom C, otherwise defaults to C<12>. =item * C<< diag => $bool >> -If true, print the raw output of valgrind as diagnostics (may be quite verbose). +If true, print the output of the test script as diagnostics. + +Ignored if you supply your own custom C, otherwise defaults to false. =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's. + +Defaults to empty. =item * -C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >> +C<< no_def_supp => $bool >> -Specifies a subroutine to execute for each test instead of C. It receives the number of bytes leaked in C<$_[0]> and the test name in C<$_[1]>, and is expected to return true if the test passed and false otherwise. Defaults to +If true, do not use the default suppression file. - sub { - is($_[0], 0, $_[1]); - (defined $_[0] and $_[0] == 0) : 1 : 0 - } +Defaults to false. =back =cut -my $run; +sub analyse { + shift; -sub _counter { - (defined $_[0] and $_[0] == 0) ? 1 : 0; -} + my %args = @_; -sub _tester { - is($_[0], 0, $_[1]); - _counter(@_); + my $instanceof = sub { + require Scalar::Util; + Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]); + }; + + my $cmd = delete $args{command}; + unless ($cmd->$instanceof('Test::Valgrind::Command')) { + require Test::Valgrind::Command; + $cmd = Test::Valgrind::Command->new( + command => $cmd || 'PerlScript', + file => delete $args{file}, + args => [ '-MTest::Valgrind=run,1' ], + ); + } + + my $tool = delete $args{tool}; + unless ($tool->$instanceof('Test::Valgrind::Tool')) { + require Test::Valgrind::Tool; + $tool = Test::Valgrind::Tool->new( + tool => $tool || 'memcheck', + callers => delete $args{callers}, + ); + } + + my $action = delete $args{action}; + unless ($action->$instanceof('Test::Valgrind::Action')) { + require Test::Valgrind::Action; + $action = Test::Valgrind::Action->new( + action => $action || 'Test', + diag => delete $args{diag}, + ); + } + + require Test::Valgrind::Session; + my $sess = eval { + Test::Valgrind::Session->new( + min_version => $tool->requires_version, + map { $_ => delete $args{$_} } qw + ); + }; + unless ($sess) { + my $err = $@; + $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/; + $action->abort($sess, $err); + return $action->status($sess); + } + + eval { + $sess->run( + command => $cmd, + tool => $tool, + action => $action, + ); + }; + if ($@) { + require Test::Valgrind::Report; + $action->report($sess, Test::Valgrind::Report->new_diag($@)); + } + + my $status = $sess->status; + $status = 255 unless defined $status; + + return $status; } +=head2 C + + use Test::Valgrind %options; + +In the parent process, L calls L with the arguments it received itself - except that if no C option was supplied, it tries to pick the first caller context that looks like a script. +When the analysis ends, it exits with the status returned by the action (for the default TAP-generator action, it's the number of failed tests). + +In the child process, it just Cs so that the calling code is actually run under C, albeit two side-effects : + +=over 4 + +=item * + +L is loaded and the destruction level is set to C<3>. + +=item * + +Autoflush on C is turned on. + +=back + +=cut + +# We use as little modules as possible in run mode so that they don't pollute +# the analysis. Hence all the requires. + +my $run; + sub import { - shift; - croak 'Optional arguments must be passed as key => value pairs' if @_ % 2; + my $class = shift; + $class = ref($class) || $class; + + if (@_ % 2) { + require Carp; + Carp::croak('Optional arguments must be passed as key => value pairs'); + } my %args = @_; - if (!defined $args{run} && !$run) { - my ($file, $pm, $next); - my $l = 0; - while ($l < 1000) { - $next = (caller $l++)[1]; + + if (defined delete $args{run} or $run) { + require Perl::Destruct::Level; + Perl::Destruct::Level::set_destruct_level(3); + { + my $oldfh = select STDOUT; + $|++; + select $oldfh; + } + $run = 1; + return; + } + + my $file = delete $args{file}; + unless (defined $file) { + my ($next, $last_pm); + for (my $l = 0; 1; ++$l) { + $next = (caller $l)[1]; last unless defined $next; - next unless $next ne '-e' and $next !~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/ - and -f $next; - if ($next =~ /\.pm$/) { - $pm = $next; + next if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/; + if ($next =~ /\.pmc?$/) { + $last_pm = $next; } else { $file = $next; + last; } } - unless (defined $file) { - $file = $pm; - return unless defined $pm; - } - my $callers = $args{callers}; - $callers = 12 unless defined $callers; - $callers = int $callers; - my $vg = Test::Valgrind::Suppressions::VG_PATH; - if (!$vg || !-x $vg) { - for (split /:/, $ENV{PATH}) { - $_ .= '/valgrind'; - if (-x) { - $vg = $_; - last; - } - } - if (!$vg) { - plan skip_all => 'No valgrind executable could be found in your path'; - return; - } - } - pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!"; - my $pid = fork; - if (!defined $pid) { - croak "fork(): $!"; - } elsif ($pid == 0) { - setpgrp 0, 0 or croak "setpgrp(0, 0): $!"; - close $rdr or croak "close(\$rdr): $!"; - open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!"; - my @args = ( - '--tool=memcheck', - '--leak-check=full', - '--leak-resolution=high', - '--num-callers=' . $callers, - '--error-limit=yes' - ); - unless ($args{no_supp}) { - for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) { - push @args, '--suppressions=' . $_ if $_; - } - } - if (defined $args{extra} and ref $args{extra} eq 'ARRAY') { - push @args, @{$args{extra}}; - } - push @args, $^X; - push @args, '-I' . $_ for @INC; - push @args, '-MTest::Valgrind=run,1', $file; - print STDERR "valgrind @args\n" if $args{diag}; - local $ENV{PERL_DESTRUCT_LEVEL} = 3; - local $ENV{PERL_DL_NONLAZY} = 1; - exec $vg, @args; - } - close $wtr or croak "close(\$wtr): $!"; - local $SIG{INT} = sub { kill -(SIGTERM) => $pid }; - plan tests => 5 unless $args{no_test}; - my @tests = ( - 'errors', - 'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable' + $file = $last_pm unless defined $file; + } + + unless (defined $file) { + require Test::Builder; + Test::Builder->new->diag('Couldn\'t find a valid source file'); + return; + } + + if ($file ne '-e') { + exit $class->analyse( + file => $file, + %args, ); - my %res = map { $_ => 0 } @tests; - while (<$rdr>) { - diag $_ if $args{diag}; - if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) { - chomp(my $err = $1); - diag "Valgrind error: $err"; - $res{$_} = undef for @tests; - } - if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) { - $res{errors} = int $1; - } elsif (/([a-z][a-z\s]*[a-z])\s*:\s*([\d.,]+)/) { - my ($cat, $count) = ($1, $2); - if (exists $res{$cat}) { - $cat =~ s/\s+/ /g; - $count =~ s/[.,]//g; - $res{$cat} = int $count; - } - } - } - waitpid $pid, 0; - my $failed = 5; - my $cb = ($args{no_test} ? \&_counter - : ($args{cb} ? $args{cb} : \&_tester)); - for (@tests) { - $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0; + } + + require File::Temp; + my $tmp = File::Temp->new; + + require Filter::Util::Call; + Filter::Util::Call::filter_add(sub { + my $status = Filter::Util::Call::filter_read(); + if ($status > 0) { + print $tmp $_; + } elsif ($status == 0) { + close $tmp; + my $code = $class->analyse( + file => $tmp->filename, + %args, + ); + exit $code; } - exit $failed; - } else { - $run = 1; + $status; + }); +} + +=head1 VARIABLES + +=head2 C<$dl_unload> + +When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at C time by L. + +Since this obfuscates error stack traces, it's disabled by default. + +=cut + +our $dl_unload; + +END { + if ($dl_unload and $run and eval { require DynaLoader; 1 }) { + my @rest; + DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs; + @DynaLoader::dl_librefs = @rest; } } =head1 CAVEATS -You can't use this module to test code given by the C<-e> command-line switch. - -Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help. +Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it. +You also have a better chance to get more accurate results if your perl is built with debugging enabled. +Using the latest C available will also help. -This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files. +This module is not really secure. +It's definitely not taint safe. +That shouldn't be a problem for test files. -If your tests output to STDERR, everything will be eaten in the process. In particular, running this module against test files will obliterate their original test results. +What your tests output to C and C is eaten unless you pass the C option, in which case it will be reprinted as diagnostics. =head1 DEPENDENCIES -Valgrind 3.1.0 (L). +L, L, L, L, L. -L, L (core modules since perl 5) and L (since 5.6.2). +=head1 SEE ALSO -L. +All the C API, including L, L, L and L. -=head1 SEE ALSO +The C man page. + +L. L, L, L. @@ -244,11 +346,12 @@ L, L, L. Vincent Pit, C<< >>, L. -You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince). +You can contact me by mail or on C (vincent). =head1 BUGS -Please report any bugs or feature requests to C, or through the web interface at L. 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, or through the web interface at L. +I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT @@ -258,13 +361,19 @@ You can find documentation for this module with the perldoc command. =head1 ACKNOWLEDGEMENTS -Rafaël Garcia-Suarez, for writing and instructing me about the existence of L (Elizabeth Mattijsen is a close second). +RafaEl Garcia-Suarez, for writing and instructing me about the existence of L (Elizabeth Mattijsen is a close second). H.Merijn Brand, for daring to test this thing. +David Cantrell, for providing shell access to one of his smokers where the tests were failing. + +The Debian-perl team, for offering all the feedback they could regarding the build issues they met. + +All you people that showed interest in this module, which motivated me into completely rewriting it. + =head1 COPYRIGHT & LICENSE -Copyright 2008 Vincent Pit, all rights reserved. +Copyright 2008,2009,2010,2011,2013 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.