]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - t/80-suppressions.t
Add a few more version tests
[perl/modules/Test-Valgrind.git] / 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 }