X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FSession.pm;h=5ddc0b6a2b22fd3de6b1bfaf724a6533c2bdb70d;hb=f2071d95aaaa4817e91cc33530deedc8d701d44d;hp=fdb51c2313cf57c0177e54d3f8a8ef37a277ea2a;hpb=63f17cfcf624bc6764d32a7e674baf6329fd2d4a;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm
index fdb51c2..5ddc0b6 100644
--- a/lib/Test/Valgrind/Session.pm
+++ b/lib/Test/Valgrind/Session.pm
@@ -9,11 +9,11 @@ Test::Valgrind::Session - Test::Valgrind session object.
 
 =head1 VERSION
 
-Version 1.15
+Version 1.19
 
 =cut
 
-our $VERSION = '1.15';
+our $VERSION = '1.19';
 
 =head1 DESCRIPTION
 
@@ -22,16 +22,19 @@ It also acts as a dispatcher between the different components.
 
 =cut
 
+use Config       ();
 use File::Spec   ();
+use ExtUtils::MM (); # MM->maybe_command()
 use Scalar::Util ();
 
-use Fcntl (); # F_SETFD
-use POSIX (); # SIGKILL
-
-use version ();
+use Fcntl       (); # F_SETFD
+use IO::Select;
+use POSIX       (); # SIGKILL, _exit()
 
 use base qw<Test::Valgrind::Carp>;
 
+use Test::Valgrind::Version;
+
 =head1 METHODS
 
 =head2 C<new>
@@ -43,6 +46,7 @@ use base qw<Test::Valgrind::Carp>;
      min_version    => $min_version,
      regen_def_supp => $regen_def_supp,
      no_def_supp    => $no_def_supp,
+     allow_no_supp  => $allow_no_supp,
      extra_supps    => \@extra_supps,
     );
 
@@ -84,6 +88,12 @@ Defaults to false.
 
 =item *
 
+If C<$allow_no_supp> is true, the command will always be run into C<valgrind> even if no appropriate suppression file is available.
+
+Defaults to false.
+
+=item *
+
 C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C<valgrind>.
 
 Defaults to none.
@@ -103,29 +113,33 @@ sub new {
  if (defined $vg and not ref $vg) {
   @paths = ($vg);
  } else {
-  push @paths, @$vg if $vg and ref $vg eq 'ARRAY';
+  push @paths, @$vg if defined $vg and ref $vg eq 'ARRAY';
   my $dirs = delete $args{search_dirs};
-  $dirs = [ File::Spec->path ] unless $dirs;
-  push @paths, map File::Spec->catfile($_, 'valgrind'), @$dirs
+  $dirs = [ File::Spec->path ] unless defined $dirs;
+  my $exe_name = 'valgrind';
+  $exe_name   .= $Config::Config{exe_ext} if defined $Config::Config{exe_ext};
+  push @paths, map File::Spec->catfile($_, $exe_name), @$dirs
                                                         if ref $dirs eq 'ARRAY';
  }
  $class->_croak('Empty valgrind candidates list') unless @paths;
 
  my $min_version = delete $args{min_version};
- defined and not ref and $_ = version->new($_) for $min_version;
+ if (defined $min_version) {
+  $min_version = Test::Valgrind::Version->new(string => $min_version);
+ }
 
  my ($valgrind, $version);
- for (@paths) {
-  next unless -x;
-  my $ver = qx/$_ --version/;
-  if ($ver =~ /^valgrind-(\d+(\.\d+)*)/) {
-   if ($min_version) {
-    $version = version->new($1);
-    next if $version < $min_version;
-   } else {
-    $version = $1;
-   }
-   $valgrind = $_;
+ for my $path (@paths) {
+  next unless defined($path) and MM->maybe_command($path);
+  my $output = qx/$path --version/;
+  my $ver    = do {
+   local $@;
+   eval { Test::Valgrind::Version->new(command_output => $output) };
+  };
+  if (defined $ver) {
+   next if defined $min_version and $ver < $min_version;
+   $valgrind = $path;
+   $version  = $ver;
    last;
   }
  }
@@ -141,6 +155,7 @@ sub new {
   version        => $version,
   regen_def_supp => delete($args{regen_def_supp}),
   no_def_supp    => delete($args{no_def_supp}),
+  allow_no_supp  => delete($args{allow_no_supp}),
   extra_supps    => $extra_supps,
  }, $class;
 }
@@ -155,18 +170,7 @@ The path to the selected C<valgrind> executable.
 
     my $valgrind_version = $tvs->version;
 
-The L<version> object associated to the selected C<valgrind>.
-
-=cut
-
-sub version {
- my ($self) = @_;
-
- my $version = $self->{version};
- $self->{version} = $version = version->new($version) unless ref $version;
-
- return $version;
-}
+The L<Test::Valgrind::Version> object associated to the selected C<valgrind>.
 
 =head2 C<regen_def_supp>
 
@@ -182,9 +186,21 @@ Read-only accessor for the C<regen_def_supp> option.
 
 Read-only accessor for the C<no_def_supp> option.
 
+=head2 C<allow_no_supp>
+
+    my $allow_no_supp = $tvs->allow_no_supp;
+
+Read-only accessor for the C<allow_no_supp> option.
+
 =cut
 
-eval "sub $_ { \$_[0]->{$_} }" for qw<valgrind regen_def_supp no_def_supp>;
+eval "sub $_ { \$_[0]->{$_} }" for qw<
+ valgrind
+ version
+ regen_def_supp
+ no_def_supp
+ allow_no_supp
+>;
 
 =head2 C<extra_supps>
 
@@ -211,26 +227,25 @@ If the command is a L<Test::Valgrind::Command::Aggregate> object, the action and
 =cut
 
 sub run {
- my $self = shift;
-
- my %args = @_;
-
- $self->start(%args);
- my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
-
- $self->_run($args{command});
-}
+ my ($self, %args) = @_;
 
-sub _run {
- my ($self, $cmd) = @_;
+ for (qw<action tool command>) {
+  my $base = 'Test::Valgrind::' . ucfirst;
+  my $value = $args{$_};
+  $self->_croak("Invalid $_") unless Scalar::Util::blessed($value)
+                                                         and $value->isa($base);
+  $self->$_($args{$_})
+ }
 
+ my $cmd = $self->command;
  if ($cmd->isa('Test::Valgrind::Command::Aggregate')) {
-  $self->_run($_) for $cmd->commands;
+  for my $subcmd ($cmd->commands) {
+   $args{command} = $subcmd;
+   $self->run(%args);
+  }
   return;
  }
 
- $self->command($cmd);
-
  $self->report($self->report_class->new_diag(
   'Using valgrind ' . $self->version . ' located at ' . $self->valgrind
  ));
@@ -240,77 +255,165 @@ sub _run {
  my @supp_args;
  if ($self->do_suppressions) {
   push @supp_args, '--gen-suppressions=all';
- } elsif (not $self->no_def_supp) {
-  my $def_supp = $self->def_supp_file;
-  my $forced;
-  if ($self->regen_def_supp and -e $def_supp) {
-   1 while unlink $def_supp;
-   $forced = 1;
+ } else {
+  if (!$self->no_def_supp) {
+   my $def_supp = $self->def_supp_file;
+   my $forced;
+   if ($self->regen_def_supp and -e $def_supp) {
+    1 while unlink $def_supp;
+    $forced = 1;
+   }
+   if (defined $def_supp and not -e $def_supp) {
+    $self->report($self->report_class->new_diag(
+     'Generating suppressions' . ($forced ? ' (forced)' : '') . '...'
+    ));
+    require Test::Valgrind::Suppressions;
+    Test::Valgrind::Suppressions->generate(
+     tool    => $self->tool,
+     command => $self->command,
+     target  => $def_supp,
+    );
+    $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp;
+    $self->report($self->report_class->new_diag(
+     "Suppressions for this perl stored in $def_supp"
+    ));
+   }
   }
-  if (defined $def_supp and not -e $def_supp) {
+  my @supp_files = grep {
+   -e $_ and $self->command->check_suppressions_file($_)
+  } $self->suppressions;
+  if (@supp_files > 1) {
+   my $files_list = join "\n", map "    $_", @supp_files;
    $self->report($self->report_class->new_diag(
-    'Generating suppressions' . ($forced ? ' (forced)' : '') . '...'
+    "Using suppressions from:\n$files_list"
    ));
-   require Test::Valgrind::Suppressions;
-   Test::Valgrind::Suppressions->generate(
-    tool    => $self->tool,
-    command => $self->command,
-    target  => $def_supp,
-   );
-   $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp;
+  } elsif (@supp_files) {
    $self->report($self->report_class->new_diag(
-    "Suppressions for this perl stored in $def_supp"
+    "Using suppressions from $supp_files[0]"
    ));
+  } elsif ($self->allow_no_supp) {
+   $self->report($self->report_class->new_diag("No suppressions used"));
+  } else {
+   $self->_croak("No compatible suppressions available");
   }
-  for ($self->suppressions) {
-   next unless -e $_;
-   $self->report($self->report_class->new_diag("Using suppression file $_"));
-   push @supp_args, "--suppressions=$_";
-  }
+  @supp_args = map "--suppressions=$_", @supp_files;
  }
 
- pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!");
- {
-  my $oldfh = select $vrdr;
-  $|++;
-  select $oldfh;
- }
+ my $error;
+ GUARDED: {
+  my $guard = Test::Valgrind::Session::Guard->new(sub { $self->finish });
+  $self->start;
 
- 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) {
-  eval 'setpgrp 0, 0';
-  close $vrdr or $self->_croak("close(\$vrdr): $!");
-  fcntl $vwtr, Fcntl::F_SETFD(), 0
+  pipe my $erdr, my $ewtr or $self->_croak("pipe(\$erdr, \$ewtr): $!");
+  {
+   my $oldfh = select $erdr;
+   $|++;
+   select $oldfh;
+  }
+
+  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 'interrupted';
- };
+   if ($aborted) {
+    $self->report($self->report_class->new_diag("valgrind has aborted"));
+    return 0;
+   }
+
+   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;
+  };
 
- close $vwtr or $self->_croak("close(\$vwtr): $!");
+  $self->{exit_code} = (waitpid($pid, 0) == $pid) ? $? >> 8 : 255;
 
- $self->parser->parse($self, $vrdr);
+  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;
 }
@@ -424,11 +527,7 @@ sub suppressions {
 
 =head2 C<start>
 
-    $tvs->start(
-     action  => $action,
-     tool    => $tool,
-     command => $command,
-    );
+    $tvs->start;
 
 Starts the action and tool associated to the current run.
 It's automatically called at the beginning of L</run>.
@@ -438,16 +537,6 @@ It's automatically called at the beginning of L</run>.
 sub start {
  my $self = shift;
 
- my %args = @_;
-
- for (qw<action tool command>) {
-  my $base = 'Test::Valgrind::' . ucfirst;
-  my $value = $args{$_};
-  $self->_croak("Invalid $_") unless Scalar::Util::blessed($value)
-                                                         and $value->isa($base);
-  $self->$_($args{$_})
- }
-
  delete @{$self}{qw<last_status exit_code>};
 
  $self->tool->start($self);
@@ -532,7 +621,7 @@ sub status { $_[0]->{last_status} }
 
 L<Test::Valgrind>, L<Test::Valgrind::Action>, L<Test::Valgrind::Command>, L<Test::Valgrind::Tool>, L<Test::Valgrind::Parser>.
 
-L<version>, L<File::HomeDir>.
+L<File::HomeDir>.
 
 =head1 AUTHOR
 
@@ -553,7 +642,7 @@ You can find documentation for this module with the perldoc command.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
+Copyright 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.