Don't try to read the script's output before valgrind's, as it causes deadlocks

[perl/modules/Test-Valgrind.git] / lib / Test / Valgrind.pm

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index 29e88580d63def80614a37f1a01c4b5f612ff21d..c76231d07ba5dada26053ea4e75e9010c996dc98 100644 (file)
--- 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 Carp qw/croak/;
 use POSIX qw/SIGTERM/;

-use Test::More;
+use Fcntl qw/F_SETFD/;
+use Test::Builder;

 
 use Perl::Destruct::Level level => 3;
 
 
 use Perl::Destruct::Level level => 3;
 


@@ -17,11 +18,11 @@ Test::Valgrind - Test Perl code through valgrind.
 
 =head1 VERSION
 
 
 =head1 VERSION
 

-Version 0.04
+Version 0.06

 
 =cut
 
 
 =cut
 

-our $VERSION = '0.04';
+our $VERSION = '0.06';

 
 =head1 SYNOPSIS
 
 
 =head1 SYNOPSIS
 


@@ -39,55 +40,100 @@ You can also use it from the command-line to test a given script :
 
     perl -MTest::Valgrind leaky.pl
 
 
     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
 
 =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.
 
 
 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.
 
 
 If true, do not use any suppressions.
 

-=item C<< callers => $number >>
+=item *
+
+C<< callers => $number >>

 
 Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
 
 
 Specify the maximum stack depth studied when valgrind encounters an error. Raising this number improves granularity. Default is 12.
 

-=item C<< extra => [ @args ] >>
+=item *
+
+C<< extra => [ @args ] >>

 
 Add C<@args> to valgrind parameters.
 
 
 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).
 
 
 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.
 
 
 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
 
 =back
 
 =cut
 

+my $Test = Test::Builder->new;
+

 my $run;
 
 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) {
 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;
   my $l = 0;
   while ($l < 1000) {
    $next = (caller $l++)[1];
    last unless defined $next;

-   $file = $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;

   }
   }

-  return if not $file or $file eq '-e';

   my $callers = $args{callers};
   $callers = 12 unless defined $callers;
   $callers = int $callers;
   my $callers = $args{callers};
   $callers = 12 unless defined $callers;
   $callers = int $callers;


@@ -101,24 +147,29 @@ sub import {
     }
    }
    if (!$vg) {
     }
    }
    if (!$vg) {

-    plan skip_all => 'No valgrind executable could be found in your path';
+    $Test->skip_all('No valgrind executable could be found in your path');

     return;
    } 
   }
     return;
    } 
   }

-  pipe my $rdr, my $wtr or croak "pipe(\$rdr, \$wtr): $!";
+  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) {
   my $pid = fork;
   if (!defined $pid) {

-   croak "fork(): $!";
+   die "fork(): $!";

   } elsif ($pid == 0) {
   } 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 = (
    my @args = (

+    $vg,

     '--tool=memcheck',
     '--leak-check=full',
     '--leak-resolution=high',
     '--num-callers=' . $callers,
     '--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}) {
    );
    unless ($args{no_supp}) {
     for (Test::Valgrind::Suppressions::supp_path(), $args{supp}) {


@@ -131,24 +182,26 @@ sub import {
    push @args, $^X;
    push @args, '-I' . $_ for @INC;
    push @args, '-MTest::Valgrind=run,1', $file;
    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;
    local $ENV{PERL_DESTRUCT_LEVEL} = 3;
    local $ENV{PERL_DL_NONLAZY} = 1;

-   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 };
   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;
   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);
    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+)/) {
     $res{$_} = undef for @tests;
    }
    if (/ERROR\s+SUMMARY\s*:\s+(\d+)/) {


@@ -163,10 +216,13 @@ sub import {
    }
   }
   waitpid $pid, 0;
    }
   }
   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) {
   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 {
   }
   exit $failed;
  } else {


@@ -188,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>).
 
 
 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>.
 
 
 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>.
 =head1 AUTHOR
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.