X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind.pm;h=c76231d07ba5dada26053ea4e75e9010c996dc98;hb=d3122f78d2a044f117a0e03fbc7dbd45d603eb47;hp=506e11fae0ad25e09e5da5ddced3733f2a68418b;hpb=d685884acaef843ed4ce04a48d7da565d52280fb;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index 506e11f..c76231d 100644
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -5,7 +5,8 @@ use warnings;
 
 use Carp qw/croak/;
 use POSIX qw/SIGTERM/;
-use Test::More;
+use Fcntl qw/F_SETFD/;
+use Test::Builder;
 
 use Perl::Destruct::Level level => 3;
 
@@ -17,11 +18,11 @@ Test::Valgrind - Test Perl code through valgrind.
 
 =head1 VERSION
 
-Version 0.03
+Version 0.06
 
 =cut
 
-our $VERSION = '0.03';
+our $VERSION = '0.06';
 
 =head1 SYNOPSIS
 
@@ -39,83 +40,136 @@ You can also use it from the command-line to test a given script :
 
     perl -MTest::Valgrind leaky.pl
 
+Due to the nature of perl's memory allocator, this module can't track leaks of Perl objects. This includes non-mortalized scalars and memory cycles. However, it can track leaks of chunks of memory allocated in XS extensions with C<Newx> and friends or C<malloc>. As such, it's complementary to the other very good leak detectors listed in the L</SEE ALSO> section.
+
 =head1 CONFIGURATION
 
 You can pass parameters to C<import> as a list of key / value pairs, where valid keys are :
 
 =over 4
 
-=item C<< supp => $file >>
+=item *
+
+C<< supp => $file >>
 
 Also use suppressions from C<$file> besides perl's.
 
-=item C<< no_supp => $bool >>
+=item *
+
+C<< no_supp => $bool >>
 
 If true, do not use any suppressions.
 
-=item C<< callers => $number >>
+=item *
 
-Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 50.
+C<< callers => $number >>
 
-=item C<< extra => [ @args ] >>
+Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
+
+=item *
+
+C<< extra => [ @args ] >>
 
 Add C<@args> to valgrind parameters.
 
-=item C<< diag => $bool >>
+=item *
+
+C<< diag => $bool >>
 
 If true, print the raw output of valgrind as diagnostics (may be quite verbose).
 
-=item C<< no_test => $bool >>
+=item *
+
+C<< no_test => $bool >>
 
 If true, do not actually output the plan and the tests results.
 
+=item *
+
+C<< cb => sub { my ($val, $name) = @_; ...; return $passed } >>
+
+Specifies a subroutine to execute for each test instead of C<Test::More::is>. It receives the number of bytes leaked in C<$_[0]> and the test name in C<$_[1]>, and is expected to return true if the test passed and false otherwise. Defaults to
+
+    sub {
+     is($_[0], 0, $_[1]);
+     (defined $_[0] and $_[0] == 0) : 1 : 0
+    }
+
 =back
 
 =cut
 
+my $Test = Test::Builder->new;
+
 my $run;
 
+sub _counter {
+ (defined $_[0] and $_[0] == 0) ? 1 : 0;
+}
+
+sub _tester {
+ $Test->is_num($_[0], 0, $_[1]);
+ _counter(@_);
+}
+
 sub import {
  shift;
  croak 'Optional arguments must be passed as key => value pairs' if @_ % 2;
  my %args = @_;
  if (!defined $args{run} && !$run) {
-  my ($file, $next);
+  my ($file, $pm, $next);
   my $l = 0;
   while ($l < 1000) {
    $next = (caller $l++)[1];
    last unless defined $next;
-   $file = $next;
-  }
-  return if not $file or $file eq '-e';
-  my $valgrind;
-  for (split /:/, $ENV{PATH}) {
-   my $vg = $_ . '/valgrind';
-   if (-x $vg) {
-    $valgrind = $vg;
-    last;
+   next unless $next ne '-e' and $next !~ /^\s*\(\s*eval\s*\d*\s*\)\s*$/
+                             and -f $next;
+   if ($next =~ /\.pm$/) {
+    $pm = $next;
+   } else {
+    $file = $next;
    }
   }
-  if (!$valgrind) {
-   plan skip_all => 'No valgrind executable could be found in your path';
-   return;
+  unless (defined $file) {
+   $file = $pm;
+   return unless defined $pm;
   }
-  my $callers = $args{callers} || 50;
+  my $callers = $args{callers};
+  $callers = 12 unless defined $callers;
   $callers = int $callers;
-  pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
+  my $vg = Test::Valgrind::Suppressions::VG_PATH;
+  if (!$vg || !-x $vg) {
+   for (split /:/, $ENV{PATH}) {
+    $_ .= '/valgrind';
+    if (-x) {
+     $vg = $_;
+     last;
+    }
+   }
+   if (!$vg) {
+    $Test->skip_all('No valgrind executable could be found in your path');
+    return;
+   } 
+  }
+  pipe my $ordr, my $owtr or die "pipe(\$ordr, \$owtr): $!";
+  pipe my $vrdr, my $vwtr or die "pipe(\$vrdr, \$vwtr): $!";
   my $pid = fork;
   if (!defined $pid) {
-   croak "fork(): $!";
+   die "fork(): $!";
   } elsif ($pid == 0) {
-   setpgrp 0, 0 or croak "setpgrp(0, 0): $!";
-   close $rdr or croak "close(\$rdr): $!";
-   open STDERR, '>&', $wtr or croak "open(STDERR, '>&', \$wtr): $!";
+   setpgrp 0, 0 or die "setpgrp(0, 0): $!";
+   close $ordr or die "close(\$ordr): $!";
+   open STDOUT, '>&=', $owtr or die "open(STDOUT, '>&=', \$owtr): $!";
+   close $vrdr or die "close(\$vrdr): $!";
+   fcntl $vwtr, F_SETFD, 0 or die "fcntl(\$vwtr, F_SETFD, 0): $!";
    my @args = (
+    $vg,
     '--tool=memcheck',
     '--leak-check=full',
     '--leak-resolution=high',
     '--num-callers=' . $callers,
-    '--error-limit=yes'
+    '--error-limit=yes',
+    '--log-fd=' . fileno($vwtr)
    );
    unless ($args{no_supp}) {
     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {
@@ -128,25 +182,26 @@ sub import {
    push @args, $^X;
    push @args, '-I' . $_ for @INC;
    push @args, '-MTest::Valgrind=run,1', $file;
-   print STDERR "valgrind @args\n" if $args{diag};
+   print STDOUT "valgrind @args\n";
    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
    local $ENV{PERL_DL_NONLAZY} = 1;
-   my $vg = Test::Valgrind::Suppressions::VG_PATH;
-   exec $vg, @args if $vg and -x $vg;
+   exec { $args[0] } @args;
+   die "exec @args: $!";
   }
-  close $wtr or croak "close(\$wtr): $!";
   local $SIG{INT} = sub { kill -(SIGTERM) => $pid };
-  plan tests => 5 unless $args{no_test};
+  $Test->plan(tests => 5) unless $args{no_test} or defined $Test->has_plan;
   my @tests = (
    'errors',
    'definitely lost', 'indirectly lost', 'possibly lost', 'still reachable'
   );
   my %res = map { $_ => 0 } @tests;
-  while (<$rdr>) {
-   diag $_ if $args{diag};
+  close $owtr or die "close(\$owtr): $!";
+  close $vwtr or die "close(\$vwtr): $!";
+  while (<$vrdr>) {
+   $Test->diag($_) if $args{diag};
    if (/^=+\d+=+\s*FATAL\s*:\s*(.*)/) {
     chomp(my $err = $1);
-    diag "Valgrind error: $err";
+    $Test->diag("Valgrind error: $err");
     $res{$_} = undef for @tests;
    }
    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {
@@ -161,10 +216,13 @@ sub import {
    }
   }
   waitpid $pid, 0;
-  my $failed = 0;
+  $Test->diag(do { local $/; <$ordr> }) if $args{diag};
+  close $ordr or die "close(\$ordr): $!";
+  my $failed = 5;
+  my $cb = ($args{no_test} ? \&_counter
+                           : ($args{cb} ? $args{cb} : \&_tester));
   for (@tests) {
-   is($res{$_}, 0, 'valgrind ' . $_) unless $args{no_test};
-   ++$failed if defined $res{$_} and $res{$_} != 0;
+   $failed -= $cb->($res{$_}, 'valgrind ' . $_) ? 1 : 0;
   }
   exit $failed;
  } else {
@@ -186,10 +244,14 @@ If your tests output to STDERR, everything will be eaten in the process. In part
 
 Valgrind 3.1.0 (L<http://valgrind.org>).
 
-L<Carp>, L<POSIX> (core modules since perl 5) and L<Test::More> (since 5.6.2).
+L<Carp>, L<Fcntl>, L<POSIX> (core modules since perl 5) and L<Test::Builder> (since 5.6.2).
 
 L<Perl::Destruct::Level>.
 
+=head1 SEE ALSO
+
+L<Devel::Leak>, L<Devel::LeakTrace>, L<Devel::LeakTrace::Fast>.
+
 =head1 AUTHOR
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.