From: Vincent Pit <perl@profvince.com>
Date: Wed, 11 Nov 2015 13:14:30 +0000 (-0200)
Subject: Make Test::Valgrind skip if no appropriate suppressions are available
X-Git-Tag: rt101934^0
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Valgrind.git;a=commitdiff_plain;h=8cacc78f5dbd91f8ff36075b44d923edd659541f

Make Test::Valgrind skip if no appropriate suppressions are available

Note that this change also fix no_def_supp => 1 ignoring extra suppressions.
---

diff --git a/MANIFEST b/MANIFEST
index 8229881..6d572f0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -38,3 +38,4 @@ t/70-session.t
 t/80-suppressions.t
 t/81-suppressions-demangle.t
 t/lib/Test/Valgrind/Test/Action.pm
+t/supp/no_perl
diff --git a/lib/Test/Valgrind/Command.pm b/lib/Test/Valgrind/Command.pm
index 0329241..a305ed6 100644
--- a/lib/Test/Valgrind/Command.pm
+++ b/lib/Test/Valgrind/Command.pm
@@ -110,6 +110,18 @@ This method must be implemented when subclassing.
 
 sub suppressions_tag;
 
+=head2 C<check_suppressions_file>
+
+    my $supp_ok = $tvc->check_suppressions_file($file);
+
+Returns a boolean indicating whether the suppressions contained in C<$file> are compatible with the command.
+
+Defaults to true.
+
+=cut
+
+sub check_suppressions_file { 1 }
+
 =head2 C<filter>
 
     my $filtered_report = $tvc->filter($session, $report);
diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm
index 7e29ffe..55c8bab 100644
--- a/lib/Test/Valgrind/Command/Perl.pm
+++ b/lib/Test/Valgrind/Command/Perl.pm
@@ -186,6 +186,23 @@ sub suppressions_tag {
  return $self->{suppressions_tag};
 }
 
+sub check_suppressions_file {
+ my ($self, $file) = @_;
+
+ {
+  open my $fh, '<', $file or return 0;
+
+  local $_;
+  while (<$fh>) {
+   return 1 if /^\s*fun:Perl_/;
+  }
+
+  close $fh;
+ }
+
+ return 0;
+}
+
 sub filter {
  my ($self, $session, $report) = @_;
 
diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm
index fdb51c2..3b377fb 100644
--- a/lib/Test/Valgrind/Session.pm
+++ b/lib/Test/Valgrind/Session.pm
@@ -43,6 +43,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 +85,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.
@@ -141,6 +148,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;
 }
@@ -182,9 +190,20 @@ 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
+ regen_def_supp
+ no_def_supp
+ allow_no_supp
+>;
 
 =head2 C<extra_supps>
 
@@ -240,33 +259,48 @@ 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): $!");
diff --git a/t/80-suppressions.t b/t/80-suppressions.t
index bb93875..b2cfa8a 100644
--- a/t/80-suppressions.t
+++ b/t/80-suppressions.t
@@ -11,13 +11,23 @@ use Test::Valgrind::Session;
 
 my $cmd = Test::Valgrind::Command->new(
  command => 'Perl',
- args    => [ ],
+ args    => [ '-e1' ],
 );
 
 my $tool = Test::Valgrind::Tool->new(
  tool => 'memcheck',
 );
 
+{
+ package Test::Valgrind::Action::Dummy;
+
+ use base 'Test::Valgrind::Action';
+
+ sub do_suppressions { 0 }
+}
+
+my $dummy_action = Test::Valgrind::Action::Dummy->new();
+
 my $sess = eval { Test::Valgrind::Session->new(
  min_version => $tool->requires_version,
 ) };
@@ -32,30 +42,61 @@ if (my $err = $@) {
 $sess->command($cmd);
 $sess->tool($tool);
 
-my $file = $sess->def_supp_file;
+my $file    = $sess->def_supp_file;
+my $VERSION = quotemeta $Test::Valgrind::Session::VERSION;
+my $exp     = qr!$VERSION/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!;
+like $file, $exp, 'default suppression file is correctly named';
 
-like($file, qr!\Q$Test::Valgrind::Session::VERSION\E/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!, 'suppression file is correctly named');
-ok(-e $file, 'suppression file exists');
-ok(-r $file, 'suppression file is readable');
+my $res = open my $supp_fh, '<', $file;
+my $err = $!;
+ok $res, 'default suppression file can be opened';
+diag "open($file): $err" unless $res;
 
-if (not open my $supp, '<', $file) {
- fail("Couldn't open the suppression file at $file: $!");
-} else {
- pass("Could open the suppression file");
- my ($in, $count, $true, $line) = (0, 0, 0, 0);
- while (<$supp>) {
-  ++$line;
+if ($res) {
+ my ($count, $non_empty, $perl_related) = (0, 0, 0);
+ my ($in, $valid_frames, $seen_perl);
+ while (<$supp_fh>) {
   chomp;
   s/^\s*//;
   s/\s*$//;
   if (!$in && $_ eq '{') {
-   $in = $line;
-  } elsif ($in && $_ eq '}') {
-   ++$count;
-   ++$true if $line - $in >= 2;
-   $in = 0;
+   $in           = 1;
+   $valid_frames = 0;
+   $seen_perl    = 0;
+  } elsif ($in) {
+   if ($_ eq '}') {
+    ++$count;
+    ++$non_empty    if $valid_frames;
+    ++$perl_related if $seen_perl;
+    $in = 0;
+   } else {
+    ++$valid_frames if /^\s*fun:/;
+    ++$seen_perl    if /^\s*fun:Perl_/;
+   }
   }
  }
- diag "$count suppressions, of which $true are not empty";
- close $supp;
+ diag "The default suppression file contains $count suppressions, of which $non_empty are not empty and $perl_related apply to perl";
+ close $supp_fh;
 }
+
+$sess = eval { Test::Valgrind::Session->new(
+ no_def_supp => 1,
+ extra_supp  => [ 't/supp/no_perl' ],
+)->run(
+ tool    => $tool,
+ command => $cmd,
+ action  => $dummy_action,
+) };
+like $@, qr/No compatible suppressions available/,
+         'incompatible suppression file';
+
+$sess = eval { Test::Valgrind::Session->new(
+ no_def_supp   => 1,
+ allow_no_supp => 1,
+ extra_supp    => [ 't/supp/no_perl' ],
+)->run(
+ tool    => $tool,
+ command => $cmd,
+ action  => $dummy_action,
+) };
+is $@, '', 'incompatible suppression file, but forced';
diff --git a/t/supp/no_perl b/t/supp/no_perl
new file mode 100644
index 0000000..9a32fec
--- /dev/null
+++ b/t/supp/no_perl
@@ -0,0 +1,9 @@
+{
+PerlSuppression999
+Memcheck:Leak
+match-leak-kinds: definite
+fun:malloc
+fun:calloc
+fun:currentlocale
+...
+}