Improve perl suppressions accuracy

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

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index ed3a1976bedd63d99446b4d1a3fc35c61bc64893..4669b23bd7bcdeae65ebeb8ca879e82b56c0330a 100644 (file)
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -96,7 +96,7 @@ C<< callers => $number >>
 Specify the maximum stack depth studied when valgrind encounters an error.
 Raising this number improves granularity.
 
 Specify the maximum stack depth studied when valgrind encounters an error.
 Raising this number improves granularity.
 

-Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<50>.

 
 =item *
 
 
 =item *
 


@@ -134,6 +134,61 @@ Defaults to empty.
 
 =cut
 
 
 =cut
 

+sub _croak {
+ require Carp;
+ Carp::croak(@_);
+}
+
+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 _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 analyse {
  shift;
 
 sub analyse {
  shift;
 


@@ -144,32 +199,21 @@ sub analyse {
   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
  };
 
   Scalar::Util::blessed($_[0]) && $_[0]->isa($_[1]);
  };
 

- my $cmd = delete $args{command};
- unless ($cmd->$instanceof('Test::Valgrind::Command')) {
-  require Test::Valgrind::Command;
-  $cmd = Test::Valgrind::Command->new(
-   command => $cmd || 'PerlScript',
-   file    => delete $args{file},
-   args    => [ '-MTest::Valgrind=run,1' ],
-  );
- }
-

  my $tool = delete $args{tool};
  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
   require Test::Valgrind::Tool;
  my $tool = delete $args{tool};
  unless ($tool->$instanceof('Test::Valgrind::Tool')) {
   require Test::Valgrind::Tool;

-  $tool = Test::Valgrind::Tool->new(
-   tool     => $tool || 'memcheck',
-   callers  => delete $args{callers},
-  );
- }
-
- my $action = delete $args{action};
- unless ($action->$instanceof('Test::Valgrind::Action')) {
-  require Test::Valgrind::Action;
-  $action = Test::Valgrind::Action->new(
-   action => $action || 'Test',
-   diag   => delete $args{diag},
-  );
+  local $@;
+  $tool = eval {
+   Test::Valgrind::Tool->new(
+    tool     => $tool || 'memcheck',
+    callers  => delete $args{callers},
+   );
+  };
+  unless ($tool) {
+   my ($err, $skippable) = $filter_errors{tool}->($@);
+   _croak($err) unless $skippable;
+   return _default_abort($err);
+  }

  }
 
  require Test::Valgrind::Session;
  }
 
  require Test::Valgrind::Session;


@@ -180,22 +224,66 @@ sub analyse {
   );
  };
  unless ($sess) {
   );
  };
  unless ($sess) {

-  my $err = $@;
-  $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/;
-  $action->abort($sess, $err);
-  return $action->status($sess);
+  my ($err, $skippable) = $filter_errors{session}->($@);
+  _croak($err) unless $skippable;
+  return _default_abort($err);

  }
 
  }
 

- eval {
-  $sess->run(
-   command => $cmd,
-   tool    => $tool,
-   action  => $action,
-  );
- };
- if ($@) {
-  require Test::Valgrind::Report;
-  $action->report($sess, Test::Valgrind::Report->new_diag($@));
+ 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 $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);
+  }
+ }
+
+ {
+  local $@;
+  eval {
+   $sess->run(
+    command => $cmd,
+    tool    => $tool,
+    action  => $action,
+   );
+   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($@));
+   }
+  }

  }
 
  my $status = $sess->status;
  }
 
  my $status = $sess->status;


@@ -236,10 +324,7 @@ sub import {
  my $class = shift;
  $class = ref($class) || $class;
 
  my $class = shift;
  $class = ref($class) || $class;
 

- if (@_ % 2) {
-  require Carp;
-  Carp::croak('Optional arguments must be passed as key => value pairs');
- }
+ _croak('Optional arguments must be passed as key => value pairs') if @_ % 2;

  my %args = @_;
 
  if (defined delete $args{run} or $run) {
  my %args = @_;
 
  if (defined delete $args{run} or $run) {