t/80-suppressions.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 4;
   7
   8 use Test::Valgrind::Command;
   9 use Test::Valgrind::Tool;
  10 use Test::Valgrind::Session;
  11
  12 use lib 't/lib';
  13 use Test::Valgrind::FakeValgrind;
  14
  15 my $cmd = Test::Valgrind::Command->new(
  16  command => 'Perl',
  17  args    => [ '-e1' ],
  18 );
  19
  20 {
  21  package Test::Valgrind::Parser::Dummy;
  22
  23  use base 'Test::Valgrind::Parser';
  24
  25  sub parse { }
  26 }
  27
  28 {
  29  package Test::Valgrind::Tool::Dummy;
  30
  31  use base 'Test::Valgrind::Tool::memcheck';
  32
  33  sub parser_class { 'Test::Valgrind::Parser::Dummy' }
  34 }
  35
  36 my $tool = Test::Valgrind::Tool::Dummy->new();
  37
  38 {
  39  package Test::Valgrind::Action::Dummy;
  40
  41  use base 'Test::Valgrind::Action';
  42
  43  sub do_suppressions { 0 }
  44
  45  sub report {
  46   my ($self, $sess, $report) = @_;
  47
  48   if ($report->is_diag) {
  49    my $contents = $report->data;
  50    if ($contents !~ /^(?:Using valgrind |No suppressions used)/) {
  51     ::diag($contents);
  52    }
  53    return;
  54   } else {
  55    $self->SUPER::report($sess, $report);
  56   }
  57  }
  58 }
  59
  60 my $dummy_action = Test::Valgrind::Action::Dummy->new();
  61
  62 SKIP: {
  63  my $sess = eval { Test::Valgrind::Session->new(
  64   min_version => $tool->requires_version,
  65  ) };
  66  if (my $err = $@) {
  67   if ($err =~ /^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/) {
  68    $err = $1;
  69   }
  70   skip $err => 2;
  71  }
  72
  73  $sess->command($cmd);
  74  $sess->tool($tool);
  75
  76  my $file    = $sess->def_supp_file;
  77  my $VERSION = quotemeta $Test::Valgrind::Session::VERSION;
  78  my $exp     = qr!$VERSION/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!;
  79  like $file, $exp, 'default suppression file is correctly named';
  80
  81  my $res = open my $supp_fh, '<', $file;
  82  my $err = $!;
  83  ok $res, 'default suppression file can be opened';
  84  diag "open($file): $err" unless $res;
  85
  86  if ($res) {
  87   my ($count, $non_empty, $perl_related) = (0, 0, 0);
  88   my ($in, $valid_frames, $seen_perl);
  89   while (<$supp_fh>) {
  90    chomp;
  91    s/^\s*//;
  92    s/\s*$//;
  93    if (!$in && $_ eq '{') {
  94     $in           = 1;
  95     $valid_frames = 0;
  96     $seen_perl    = 0;
  97    } elsif ($in) {
  98     if ($_ eq '}') {
  99      ++$count;
 100      ++$non_empty    if $valid_frames;
 101      ++$perl_related if $seen_perl;
 102      $in = 0;
 103     } else {
 104      ++$valid_frames if /^\s*fun:/;
 105      ++$seen_perl    if /^\s*fun:(Perl|S|XS)_/
 106                      or /^\s*obj:.*perl/;
 107     }
 108    }
 109   }
 110   diag "The default suppression file contains $count suppressions, of which $non_empty are not empty and $perl_related apply to perl";
 111   close $supp_fh;
 112  }
 113 }
 114
 115 delete $ENV{PATH};
 116
 117 SKIP: {
 118  my $dummy_vg = Test::Valgrind::FakeValgrind->new();
 119  skip $dummy_vg => 2 unless ref $dummy_vg;
 120
 121  eval { Test::Valgrind::Session->new(
 122   valgrind    => $dummy_vg->path,
 123   no_def_supp => 1,
 124   extra_supp  => [ 't/supp/no_perl' ],
 125  )->run(
 126   tool    => $tool,
 127   command => $cmd,
 128   action  => $dummy_action,
 129  ) };
 130  like $@, qr/No compatible suppressions available/,
 131           'incompatible suppression file';
 132
 133  eval { Test::Valgrind::Session->new(
 134   valgrind      => $dummy_vg->path,
 135   no_def_supp   => 1,
 136   allow_no_supp => 1,
 137   extra_supp    => [ 't/supp/no_perl' ],
 138  )->run(
 139   tool    => $tool,
 140   command => $cmd,
 141   action  => $dummy_action,
 142  ) };
 143  is $@, '', 'incompatible suppression file, but forced';
 144 }