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

[perl/modules/Test-Valgrind.git] / t / 80-suppressions.t

diff --git a/t/80-suppressions.t b/t/80-suppressions.t
index bb93875bf15dd7467aeef3714775158c9737f082..b2cfa8a5a25fed2843c58a309eb3ad7d7af956a6 100644 (file)
--- 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';