Improve error handling before exec

IO::Select is required.

diff --git a/MANIFEST b/MANIFEST
index 0573979ca386342cdbdb1f133bb7eb2fa27d3e39..d1c536666bb1ac467e5f9df194af1f65db3308f9 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -37,6 +37,7 @@ t/12-good-run-exception.t
 t/20-bad.t
 t/30-skip.t
 t/70-session.t
+t/71-session-command.t
 t/80-suppressions.t
 t/81-suppressions-demangle.t
 t/lib/Test/Valgrind/FakeValgrind.pm

diff --git a/Makefile.PL b/Makefile.PL
index f6fb3bea9af2dc01dedc6c2d25d5ef81f55a1841..202071d32d759df1729caaf79f39f53337509a77 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -130,6 +130,7 @@ my %PREREQ_PM = (
  'File::Temp'            => '0.14', # OO interface
  'Filter::Util::Call'    => 0,
  'Fcntl'                 => 0,
+ 'IO::Select'            => 0,
  'List::Util'            => 0,
  'POSIX'                 => 0,
  'Perl::Destruct::Level' => 0,

diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm
index b0069df7fdf1c2534218f2b644d42a75a8add912..99f83149692341554d5bb428ac1bda14867413a5 100644 (file)
--- a/lib/Test/Valgrind/Session.pm
+++ b/lib/Test/Valgrind/Session.pm
@@ -25,8 +25,9 @@ It also acts as a dispatcher between the different components.
 use File::Spec   ();
 use Scalar::Util ();
 
-use Fcntl (); # F_SETFD
-use POSIX (); # SIGKILL
+use Fcntl       (); # F_SETFD
+use IO::Select;
+use POSIX       (); # SIGKILL, _exit()
 
 use version ();
 
@@ -302,56 +303,121 @@ sub run {
   @supp_args = map "--suppressions=$_", @supp_files;
  }
 
- my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
- $self->start;
+ my $error;
+ GUARDED: {
+  my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
+  $self->start;
 
- 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;
+  pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
+  {
+   my $oldfh = select $vrdr;
+   $|++;
+   select $oldfh;
+  }
 
- if ($pid == 0) {
+  pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!");
   {
-   local $@;
-   eval { setpgrp(0, 0) };
+   my $oldfh = select $erdr;
+   $|++;
+   select $oldfh;
   }
-  close $vrdr or $self->_croak("close(\$vrdr): $!");
-  fcntl $vwtr, Fcntl::F_SETFD(), 0
+
+  my $pid = fork;
+  $self->_croak("fork(): $!") unless defined $pid;
+
+  if ($pid == 0) {
+   {
+    local $@;
+    eval { setpgrp(0, 0) };
+   }
+
+   close $erdr or POSIX::_exit(255);
+
+   local $@;
+   eval {
+    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,
-   $self->tool->args($self),
-   @supp_args,
-   $self->parser->args($self, $vwtr),
-   $self->command->args($self),
-  );
+    my @args = (
+     $self->valgrind,
+     $self->tool->args($self),
+     @supp_args,
+     $self->parser->args($self, $vwtr),
+     $self->command->args($self),
+    );
 
-#  $self->report($self->report_class->new_diag("@args"));
+    {
+     no warnings 'exec';
+     exec { $args[0] } @args;
+    }
+    $self->_croak("exec @args: $!");
+   };
 
-  exec { $args[0] } @args or $self->_croak("exec @args: $!");
- }
+   print $ewtr $@;
+   close $ewtr;
+
+   POSIX::_exit(255);
+  }
+
+  local $@;
+  eval {
+   local $SIG{INT} = sub {
+    die 'valgrind analysis was interrupted';
+   };
+
+   close $vwtr or $self->_croak("close(\$vwtr): $!");
+   close $ewtr or $self->_croak("close(\$ewtr): $!");
+
+   SEL: {
+    my $sel = IO::Select->new($vrdr, $erdr);
+
+    my $child_err;
+    while (my @ready = $sel->can_read) {
+     last SEL if @ready == 1 and fileno $ready[0] == fileno $vrdr;
+
+     my $buf;
+     my $bytes_read = sysread $erdr, $buf, 4096;
+     if (not defined $bytes_read) {
+      $self->_croak("sysread(\$erdr): $!");
+     } elsif ($bytes_read) {
+      $sel->remove($vrdr) unless $child_err;
+      $child_err .= $buf;
+     } else {
+      $sel->remove($erdr);
+      die $child_err if $child_err;
+     }
+    }
+   }
+
+   my $aborted = $self->parser->parse($self, $vrdr);
 
- local $SIG{INT} = sub {
-  kill -(POSIX::SIGKILL()) => $pid;
-  waitpid $pid, 0;
-  die 'valgrind analysis was interrupted';
- };
+   if ($aborted) {
+    $self->report($self->report_class->new_diag("valgrind has aborted"));
+    return 0;
+   }
 
- close $vwtr or $self->_croak("close(\$vwtr): $!");
+   1;
+  } or do {
+   $error = $@;
+   kill -(POSIX::SIGKILL()) => $pid if kill 0 => $pid;
+   close $erdr;
+   close $vrdr;
+   waitpid $pid, 0;
+   # Force the guard destructor to trigger now so that old perls don't lose $@
+   last GUARDED;
+  };
 
- my $aborted = $self->parser->parse($self, $vrdr);
+  $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
 
- kill -(POSIX::SIGKILL()) => $pid if $aborted;
+  close $erdr or $self->_croak("close(\$erdr): $!");
+  close $vrdr or $self->_croak("close(\$vrdr): $!");
 
- $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
+  return;
+ }
 
- close $vrdr or $self->_croak("close(\$vrdr): $!");
+ die $error if $error;
 
  return;
 }

diff --git a/t/71-session-command.t b/t/71-session-command.t
new file mode 100644 (file)
index 0000000..54ce89d
--- /dev/null
+++ b/t/71-session-command.t
@@ -0,0 +1,95 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use Test::Valgrind::Command;
+use Test::Valgrind::Tool;
+use Test::Valgrind::Session;
+
+use lib 't/lib';
+use Test::Valgrind::FakeValgrind;
+
+my $cmd = Test::Valgrind::Command->new(
+ command => 'Perl',
+ args    => [ '-e1' ],
+);
+
+{
+ package Test::Valgrind::Parser::Dummy;
+
+ use base 'Test::Valgrind::Parser';
+
+ sub parse { }
+}
+
+{
+ package Test::Valgrind::Tool::Dummy;
+
+ use base 'Test::Valgrind::Tool::memcheck';
+
+ sub parser_class { 'Test::Valgrind::Parser::Dummy' }
+}
+
+my $tool = Test::Valgrind::Tool::Dummy->new();
+
+{
+ package Test::Valgrind::Action::Dummy;
+
+ use base 'Test::Valgrind::Action';
+
+ sub do_suppressions { 0 }
+
+ sub report {
+  my ($self, $sess, $report) = @_;
+
+  if ($report->is_diag) {
+   my $contents = $report->data;
+   if ($contents !~ /^(?:Using valgrind |No suppressions used)/) {
+    ::diag($contents);
+   }
+   return;
+  } else {
+   $self->SUPER::report($sess, $report);
+  }
+ }
+}
+
+my $action = Test::Valgrind::Action::Dummy->new();
+
+SKIP: {
+ my $tmp_vg;
+ my $sess;
+
+ {
+  my $dummy_vg = Test::Valgrind::FakeValgrind->new(
+   exe_name => 'invisible_pink_unicorn'
+  );
+  skip $dummy_vg => 2 unless ref $dummy_vg;
+  $tmp_vg = $dummy_vg->path;
+
+  local $@;
+  $sess = eval {
+   Test::Valgrind::Session->new(
+    allow_no_supp => 1,
+    no_def_supp   => 1,
+    valgrind      => $tmp_vg,
+   );
+  };
+  is $@, '', 'session was correctly created';
+ }
+
+ skip 'dummy valgrind executable was not deleted' => 1 if -e $tmp_vg;
+
+ local $@;
+ eval {
+  $sess->run(
+   action  => $action,
+   command => $cmd,
+   tool    => $tool,
+  );
+ };
+ like $@, qr/invisible_pink_unicorn/, 'command not found croaks';
+}