X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind.pm;h=43c045886e0203196a2f1e05d9b934aa83b03cc8;hb=f2071d95aaaa4817e91cc33530deedc8d701d44d;hp=e8925d86cdd19523f96a363bc09a446379a521f9;hpb=1a45e7f9e0b3b355dbfe3a3e70d638880aa2b264;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index e8925d8..43c0458 100644
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -3,240 +3,450 @@ 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.19
 
 =cut
 
-our $VERSION = '0.051';
+our $VERSION = '1.19';
 
 =head1 SYNOPSIS
 
+    # From the command-line
+    perl -MTest::Valgrind leaky.pl
+
+    # From the command-line, snippet style
+    perl -MTest::Valgrind -e 'leaky()'
+
+    # In a test file
     use Test::More;
     eval 'use Test::Valgrind';
     plan skip_all => 'Test::Valgrind is required to test your distribution with valgrind' if $@;
+    leaky();
 
-    # Code to inspect for memory leaks/errors.
+    # In all the test files of a directory
+    prove --exec 'perl -Iblib/lib -Iblib/arch -MTest::Valgrind' t/*.t
 
 =head1 DESCRIPTION
 
-This module lets you run some code through the B<valgrind> memory debugger, to test it for memory errors and leaks. Just add C<use Test::Valgrind> at the beginning of the code you want to test. Behind the hood, C<Test::Valgrind::import> forks so that the child can basically C<exec 'valgrind', $^X, $0> (except that of course C<$0> isn't right there). The parent then parses the report output by valgrind and pass or fail tests accordingly.
+This module is a front-end to the C<Test::Valgrind::*> API that lets you run Perl code through the C<memcheck> tool of the C<valgrind> memory debugger, to test for memory errors and leaks.
+If they aren't available yet, it will first generate suppressions for the current C<perl> interpreter and store them in the portable flavour of F<~/.perl/Test-Valgrind/suppressions/$VERSION>.
+The actual run will then take place, and tests will be passed or failed according to the result of the analysis.
 
-You can also use it from the command-line to test a given script :
+The complete API is much more versatile than this.
+By declaring an appropriate L<Test::Valgrind::Command> class, you can run any executable (that is, not only Perl scripts) under valgrind, generate the corresponding suppressions on-the-fly and convert the analysis result to TAP output so that it can be incorporated into your project's testsuite.
+If you're not interested in producing TAP, you can output the results in whatever format you like (for example HTML pages) by defining your own L<Test::Valgrind::Action> class.
 
-    perl -MTest::Valgrind leaky.pl
+Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects.
+This includes non-mortalized scalars and memory cycles.
+However, it can track leaks of chunks of memory allocated in XS extensions with C<Newx> and friends or C<malloc>.
+As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
+
+=head1 METHODS
 
-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.
+=head2 C<analyse>
 
-=head1 CONFIGURATION
+    Test::Valgrind->analyse(%options);
 
-You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
+Run a C<valgrind> analysis configured by C<%options> :
 
 =over 4
 
 =item *
 
-C<< supp => $file >>
+C<< command => $command >>
 
-Also use suppressions from C<$file> besides perl's.
+The L<Test::Valgrind::Command> object (or class name) to use.
+
+Defaults to L<Test::Valgrind::Command::PerlScript>.
 
 =item *
 
-C<< no_supp => $bool >>
+C<< tool => $tool >>
+
+The L<Test::Valgrind::Tool> object (or class name) to use.
 
-If true, do not use any suppressions.
+Defaults to L<Test::Valgrind::Tool::memcheck>.
 
 =item *
 
-C<< callers => $number >>
+C<< action => $action >>
+
+The L<Test::Valgrind::Action> object (or class name) to use.
+
+Defaults to L<Test::Valgrind::Action::Test>.
+
+=item *
+
+C<< file => $file >>
 
-Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
+The file name of the script to analyse.
+
+Ignored if you supply your own custom C<command>, but mandatory otherwise.
 
 =item *
 
-C<< extra => [ @args ] >>
+C<< callers => $number >>
+
+Specify the maximum stack depth studied when valgrind encounters an error.
+Raising this number improves granularity.
 
-Add C<@args> to valgrind parameters.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<24> (the maximum allowed by C<valgrind>).
 
 =item *
 
 C<< diag => $bool >>
 
-If true, print the raw output of valgrind as diagnostics (may be quite verbose).
+If true, print the output of the test script as diagnostics.
+
+Ignored if you supply your own custom C<action>, otherwise defaults to false.
+
+=item *
+
+C<< regen_def_supp => $bool >>
+
+If true, forcefully regenerate the default suppression file.
+
+Defaults to false.
+
+=item *
+
+C<< no_def_supp => $bool >>
+
+If true, do not use the default suppression file.
+
+Defaults to false.
 
 =item *
 
-C<< no_test => $bool >>
+C<< allow_no_supp => $bool >>
 
-If true, do not actually output the plan and the tests results.
+If true, force running the analysis even if the suppression files do not refer to any C<perl>-related symbol.
+
+Defaults to false.
 
 =item *
 
-C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >>
+C<< extra_supps => \@files >>
 
-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
+Also use suppressions from C<@files> besides C<perl>'s.
 
-    sub {
-     is($_[0], 0, $_[1]);
-     (defined $_[0] and $_[0] == 0) : 1 : 0
-    }
+Defaults to empty.
 
 =back
 
 =cut
 
-my $run;
+sub _croak {
+ require Carp;
+ Carp::croak(@_);
+}
 
-sub _counter {
- (defined $_[0] and $_[0] == 0) ? 1 : 0;
+my %skippable_errors = (
+ session => [
+  'Empty valgrind candidates list',
+  'No appropriate valgrind executable could be found',
+ ],
+ action  => [ ],
+ tool    => [ ],
+ command => [ ],
+ run     => [
+  'No compatible suppressions available',
+ ],
+);
+
+my %filter_errors;
+
+for my $obj (keys %skippable_errors) {
+ my @errors = @{$skippable_errors{$obj} || []};
+ if (@errors) {
+  my $rxp   = join '|', @errors;
+  $rxp      = qr/($rxp)\s+at.*/;
+  $filter_errors{$obj} = sub {
+   my ($err) = @_;
+   if ($err =~ /$rxp/) {
+    return ($1, 1);
+   } else {
+    return ($err, 0);
+   }
+  };
+ } else {
+  $filter_errors{$obj} = sub {
+   return ($_[0], 0);
+  };
+ }
 }
 
-sub _tester {
- is($_[0], 0, $_[1]);
- _counter(@_);
+sub _default_abort {
+ my ($err) = @_;
+
+ require Test::Builder;
+ my $tb   = Test::Builder->new;
+ my $plan = $tb->has_plan;
+ if (defined $plan) {
+  $tb->BAIL_OUT($err);
+  return 255;
+ } else {
+  $tb->skip_all($err);
+  return 0;
+ }
 }
 
-sub import {
+sub analyse {
  shift;
- croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
+
  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;
-   }
+
+ my $instanceof = sub {
+  require Scalar::Util;
+  Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
+ };
+
+ my $tool = delete $args{tool};
+ unless ($tool->$instanceof('Test::Valgrind::Tool')) {
+  my $callers = delete $args{callers} || 24;
+  $callers = 24 if $callers <= 0;
+  require Test::Valgrind::Tool;
+  local $@;
+  $tool = eval {
+   Test::Valgrind::Tool->new(
+    tool    => $tool || 'memcheck',
+    callers => $callers,
+   );
+  };
+  unless ($tool) {
+   my ($err, $skippable) = $filter_errors{tool}->($@);
+   _croak($err) unless $skippable;
+   return _default_abort($err);
   }
-  unless (defined $file) {
-   $file = $pm;
-   return unless defined $pm;
+ }
+
+ require Test::Valgrind::Session;
+ my $sess = eval {
+  Test::Valgrind::Session->new(
+   min_version => $tool->requires_version,
+   map { $_ => delete $args{$_} } qw<
+    regen_def_supp
+    no_def_supp
+    allow_no_supp
+    extra_supps
+   >
+  );
+ };
+ unless ($sess) {
+  my ($err, $skippable) = $filter_errors{session}->($@);
+  _croak($err) unless $skippable;
+  return _default_abort($err);
+ }
+
+ my $action = delete $args{action};
+ unless ($action->$instanceof('Test::Valgrind::Action')) {
+  require Test::Valgrind::Action;
+  local $@;
+  $action = eval {
+   Test::Valgrind::Action->new(
+    action => $action || 'Test',
+    diag   => delete $args{diag},
+   );
+  };
+  unless ($action) {
+   my ($err, $skippable) = $filter_errors{action}->($@);
+   _croak($err) unless $skippable;
+   return _default_abort($err);
   }
-  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;
-   } 
+ }
+
+ my $cmd = delete $args{command};
+ unless ($cmd->$instanceof('Test::Valgrind::Command')) {
+  require Test::Valgrind::Command;
+  local $@;
+  $cmd = eval {
+   Test::Valgrind::Command->new(
+    command => $cmd || 'PerlScript',
+    file    => delete $args{file},
+    args    => [ '-MTest::Valgrind=run,1' ],
+   );
+  };
+  unless ($cmd) {
+   my ($err, $skippable) = $filter_errors{command}->($@);
+   _croak($err) unless $skippable;
+   $action->abort($sess, $err);
+   return $action->status($sess);
   }
-  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'
+ }
+
+ {
+  local $@;
+  eval {
+   $sess->run(
+    command => $cmd,
+    tool    => $tool,
+    action  => $action,
    );
-   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}};
+   1
+  } or do {
+   my ($err, $skippable) = $filter_errors{run}->($@);
+   if ($skippable) {
+    $action->abort($sess, $err);
+    return $action->status($sess);
+   } else {
+    require Test::Valgrind::Report;
+    $action->report($sess, Test::Valgrind::Report->new_diag($@));
    }
-   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'
-  );
-  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;
-    }
+ }
+
+ my $status = $sess->status;
+ $status = 255 unless defined $status;
+
+ return $status;
+}
+
+=head2 C<import>
+
+    use Test::Valgrind %options;
+
+In the parent process, L</import> calls L</analyse> with the arguments it received itself - except that if no C<file> option was supplied, it tries to pick the first caller context that looks like a script.
+When the analysis ends, it exits with the status returned by the action (for the default TAP-generator action, it's the number of failed tests).
+
+In the child process, it just C<return>s so that the calling code is actually run under C<valgrind>, albeit two side-effects :
+
+=over 4
+
+=item *
+
+L<Perl::Destruct::Level> is loaded and the destruction level is set to C<3>.
+
+=item *
+
+Autoflush on C<STDOUT> is turned on.
+
+=back
+
+=cut
+
+# We use as little modules as possible in run mode so that they don't pollute
+# the analysis. Hence all the requires.
+
+my $run;
+
+sub import {
+ my $class = shift;
+ $class = ref($class) || $class;
+
+ _croak('Optional arguments must be passed as key => value pairs') if @_ % 2;
+ my %args = @_;
+
+ 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 if $next =~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/;
+   if ($next =~ /\.pmc?$/) {
+    $last_pm = $next;
+   } else {
+    $file = $next;
+    last;
    }
   }
-  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;
+  $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,
+  );
+ }
+
+ require File::Temp;
+ my $tmp = File::Temp->new;
+
+ require Filter::Util::Call;
+ Filter::Util::Call::filter_add(sub {
+  my $status = Filter::Util::Call::filter_read();
+  if ($status > 0) {
+   print $tmp $_;
+  } elsif ($status == 0) {
+   close $tmp;
+   my $code = $class->analyse(
+    file => $tmp->filename,
+    %args,
+   );
+   exit $code;
   }
-  exit $failed;
- } else {
-  $run = 1;
+  $status;
+ });
+}
+
+=head1 VARIABLES
+
+=head2 C<$dl_unload>
+
+When set to true, all dynamic extensions that were loaded during the analysis will be unloaded at C<END> time by L<DynaLoader/dl_unload_file>.
+
+Since this obfuscates error stack traces, it's disabled by default.
+
+=cut
+
+our $dl_unload;
+
+END {
+ if ($dl_unload and $run and eval { require DynaLoader; 1 }) {
+  my @rest;
+  DynaLoader::dl_unload_file($_) or push @rest, $_ for @DynaLoader::dl_librefs;
+  @DynaLoader::dl_librefs = @rest;
  }
 }
 
 =head1 CAVEATS
 
-You can't use this module to test code given by the C<-e> command-line switch.
+Perl 5.8 is notorious for leaking like there's no tomorrow, so the suppressions are very likely not to be complete on it.
+You also have a better chance to get more accurate results if your perl is built with debugging enabled.
+Using the latest C<valgrind> available will also help.
 
-Results will most likely be better if your perl is built with debugging enabled. Using the latest valgrind available will also help.
+This module is not really secure.
+It's definitely not taint safe.
+That shouldn't be a problem for test files.
 
-This module is not really secure. It's definitely not taint safe. That shouldn't be a problem for test files.
-
-If your tests output to STDERR, everything will be eaten in the process. In particular, running this module against test files will obliterate their original test results.
+What your tests output to C<STDOUT> and C<STDERR> is eaten unless you pass the C<diag> option, in which case it will be reprinted as diagnostics.
 
 =head1 DEPENDENCIES
 
-Valgrind 3.1.0 (L<http://valgrind.org>).
+L<XML::Twig>, L<File::HomeDir>, L<Env::Sanctify>, L<Perl::Destruct::Level>.
+
+=head1 SEE ALSO
 
-L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
+All the C<Test::Valgrind::*> API, including L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Action> and L<Test::Valgrind::Session>.
 
-L<Perl::Destruct::Level>.
+The C<valgrind(1)> man page.
 
-=head1 SEE ALSO
+L<Test::LeakTrace>.
 
 L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 
@@ -244,11 +454,12 @@ L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 
-You can contact me by mail or on #perl @ FreeNode (vincent or Prof_Vince).
+You can contact me by mail or on C<irc.perl.org> (vincent).
 
 =head1 BUGS
 
-Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.  I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 
 =head1 SUPPORT
 
@@ -258,13 +469,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<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
+RafaE<euml>l Garcia-Suarez, for writing and instructing me about the existence of L<Perl::Destruct::Level> (Elizabeth Mattijsen is a close second).
 
 H.Merijn Brand, for daring to test this thing.
 
+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,2015,2016 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.