t/80-suppressions.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   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 my $sess = eval { Test::Valgrind::Session->new(
  63  min_version => $tool->requires_version,
  64 ) };
  65
  66 if (my $err = $@) {
  67  $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/;
  68  plan skip_all => $err;
  69 } else {
  70  plan tests => 4;
  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_/;
 106    }
 107   }
 108  }
 109  diag "The default suppression file contains $count suppressions, of which $non_empty are not empty and $perl_related apply to perl";
 110  close $supp_fh;
 111 }
 112
 113 SKIP: {
 114  my $dummy_vg = Test::Valgrind::FakeValgrind->new();
 115  skip $dummy_vg => 2 unless ref $dummy_vg;
 116
 117  $sess = eval { Test::Valgrind::Session->new(
 118   valgrind    => $dummy_vg->path,
 119   no_def_supp => 1,
 120   extra_supp  => [ 't/supp/no_perl' ],
 121  )->run(
 122   tool    => $tool,
 123   command => $cmd,
 124   action  => $dummy_action,
 125  ) };
 126  like $@, qr/No compatible suppressions available/,
 127           'incompatible suppression file';
 128
 129  $sess = eval { Test::Valgrind::Session->new(
 130   valgrind      => $dummy_vg->path,
 131   no_def_supp   => 1,
 132   allow_no_supp => 1,
 133   extra_supp    => [ 't/supp/no_perl' ],
 134  )->run(
 135   tool    => $tool,
 136   command => $cmd,
 137   action  => $dummy_action,
 138  ) };
 139  is $@, '', 'incompatible suppression file, but forced';
 140 }