X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind.pm;h=9b233c73e9371553de86006a01ae275031133b19;hb=01d49783af4ec2292a5fe23164bbef36119613e0;hp=5e95a9fffb87ed30cc37ce0752eba1cbf54b7fae;hpb=b354437c7e018fdd1861e90a58f1f639c6bcf047;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index 5e95a9f..9b233c7 100644
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -9,11 +9,11 @@ Test::Valgrind - Generate suppressions, analyse and test any command with valgri
 
 =head1 VERSION
 
-Version 1.14
+Version 1.15
 
 =cut
 
-our $VERSION = '1.14';
+our $VERSION = '1.15';
 
 =head1 SYNOPSIS
 
@@ -96,7 +96,7 @@ C<< callers => $number >>
 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 *
 
@@ -108,11 +108,11 @@ Ignored if you supply your own custom C<action>, otherwise defaults to false.
 
 =item *
 
-C<< extra_supps => \@files >>
+C<< regen_def_supp => $bool >>
 
-Also use suppressions from C<@files> besides C<perl>'s.
+If true, forcefully regenerate the default suppression file.
 
-Defaults to empty.
+Defaults to false.
 
 =item *
 
@@ -122,10 +122,81 @@ If true, do not use the default suppression file.
 
 Defaults to false.
 
+=item *
+
+C<< allow_no_supp => $bool >>
+
+If true, force running the analysis even if the suppression files do not refer to any C<perl>-related symbol.
+
+Defaults to false.
+
+=item *
+
+C<< extra_supps => \@files >>
+
+Also use suppressions from C<@files> besides C<perl>'s.
+
+Defaults to empty.
+
 =back
 
 =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;
 
@@ -136,58 +207,96 @@ sub analyse {
   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;
-  $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;
  my $sess = eval {
   Test::Valgrind::Session->new(
    min_version => $tool->requires_version,
-   map { $_ => delete $args{$_} } qw<extra_supps no_def_supp>
+   map { $_ => delete $args{$_} } qw<
+    regen_def_supp
+    no_def_supp
+    allow_no_supp
+    extra_supps
+   >
   );
  };
  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;
@@ -228,10 +337,7 @@ sub import {
  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) {
@@ -373,7 +479,7 @@ All you people that showed interest in this module, which motivated me into comp
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2008,2009,2010,2011,2013 Vincent Pit, all rights reserved.
+Copyright 2008,2009,2010,2011,2013,2015 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.