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 my $cmd = Test::Valgrind::Command->new(
  13  command => 'Perl',
  14  args    => [ '-e1' ],
  15 );
  16
  17 my $tool = Test::Valgrind::Tool->new(
  18  tool => 'memcheck',
  19 );
  20
  21 {
  22  package Test::Valgrind::Action::Dummy;
  23
  24  use base 'Test::Valgrind::Action';
  25
  26  sub do_suppressions { 0 }
  27 }
  28
  29 my $dummy_action = Test::Valgrind::Action::Dummy->new();
  30
  31 my $sess = eval { Test::Valgrind::Session->new(
  32  min_version => $tool->requires_version,
  33 ) };
  34
  35 if (my $err = $@) {
  36  $err =~ s/^(Empty valgrind candidates list|No appropriate valgrind executable could be found)\s+at.*/$1/;
  37  plan skip_all => $err;
  38 } else {
  39  plan tests => 4;
  40 }
  41
  42 $sess->command($cmd);
  43 $sess->tool($tool);
  44
  45 my $file    = $sess->def_supp_file;
  46 my $VERSION = quotemeta $Test::Valgrind::Session::VERSION;
  47 my $exp     = qr!$VERSION/memcheck-\d+(?:\.\d+)*-[0-9a-f]{32}\.supp$!;
  48 like $file, $exp, 'default suppression file is correctly named';
  49
  50 my $res = open my $supp_fh, '<', $file;
  51 my $err = $!;
  52 ok $res, 'default suppression file can be opened';
  53 diag "open($file): $err" unless $res;
  54
  55 if ($res) {
  56  my ($count, $non_empty, $perl_related) = (0, 0, 0);
  57  my ($in, $valid_frames, $seen_perl);
  58  while (<$supp_fh>) {
  59   chomp;
  60   s/^\s*//;
  61   s/\s*$//;
  62   if (!$in && $_ eq '{') {
  63    $in           = 1;
  64    $valid_frames = 0;
  65    $seen_perl    = 0;
  66   } elsif ($in) {
  67    if ($_ eq '}') {
  68     ++$count;
  69     ++$non_empty    if $valid_frames;
  70     ++$perl_related if $seen_perl;
  71     $in = 0;
  72    } else {
  73     ++$valid_frames if /^\s*fun:/;
  74     ++$seen_perl    if /^\s*fun:Perl_/;
  75    }
  76   }
  77  }
  78  diag "The default suppression file contains $count suppressions, of which $non_empty are not empty and $perl_related apply to perl";
  79  close $supp_fh;
  80 }
  81
  82 $sess = eval { Test::Valgrind::Session->new(
  83  no_def_supp => 1,
  84  extra_supp  => [ 't/supp/no_perl' ],
  85 )->run(
  86  tool    => $tool,
  87  command => $cmd,
  88  action  => $dummy_action,
  89 ) };
  90 like $@, qr/No compatible suppressions available/,
  91          'incompatible suppression file';
  92
  93 $sess = eval { Test::Valgrind::Session->new(
  94  no_def_supp   => 1,
  95  allow_no_supp => 1,
  96  extra_supp    => [ 't/supp/no_perl' ],
  97 )->run(
  98  tool    => $tool,
  99  command => $cmd,
 100  action  => $dummy_action,
 101 ) };
 102 is $@, '', 'incompatible suppression file, but forced';