From: Vincent Pit Date: Wed, 11 Nov 2015 13:14:30 +0000 (-0200) Subject: Make Test::Valgrind skip if no appropriate suppressions are available X-Git-Tag: rt101934 X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=00e7bab5119b22c160e00d4ac54c3b7a5a8b5e18;p=perl%2Fmodules%2FTest-Valgrind.git Make Test::Valgrind skip if no appropriate suppressions are available Note that this change also fix no_def_supp => 1 ignoring extra suppressions. --- diff --git a/MANIFEST b/MANIFEST index 8229881..6d572f0 100644 --- a/MANIFEST +++ b/MANIFEST @@ -38,3 +38,4 @@ t/70-session.t t/80-suppressions.t t/81-suppressions-demangle.t t/lib/Test/Valgrind/Test/Action.pm +t/supp/no_perl diff --git a/lib/Test/Valgrind/Command.pm b/lib/Test/Valgrind/Command.pm index 0329241..a305ed6 100644 --- a/lib/Test/Valgrind/Command.pm +++ b/lib/Test/Valgrind/Command.pm @@ -110,6 +110,18 @@ This method must be implemented when subclassing. sub suppressions_tag; +=head2 C + + my $supp_ok = $tvc->check_suppressions_file($file); + +Returns a boolean indicating whether the suppressions contained in C<$file> are compatible with the command. + +Defaults to true. + +=cut + +sub check_suppressions_file { 1 } + =head2 C my $filtered_report = $tvc->filter($session, $report); diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm index 7e29ffe..55c8bab 100644 --- a/lib/Test/Valgrind/Command/Perl.pm +++ b/lib/Test/Valgrind/Command/Perl.pm @@ -186,6 +186,23 @@ sub suppressions_tag { return $self->{suppressions_tag}; } +sub check_suppressions_file { + my ($self, $file) = @_; + + { + open my $fh, '<', $file or return 0; + + local $_; + while (<$fh>) { + return 1 if /^\s*fun:Perl_/; + } + + close $fh; + } + + return 0; +} + sub filter { my ($self, $session, $report) = @_; diff --git a/lib/Test/Valgrind/Session.pm b/lib/Test/Valgrind/Session.pm index fdb51c2..3b377fb 100644 --- a/lib/Test/Valgrind/Session.pm +++ b/lib/Test/Valgrind/Session.pm @@ -43,6 +43,7 @@ use base qw; min_version => $min_version, regen_def_supp => $regen_def_supp, no_def_supp => $no_def_supp, + allow_no_supp => $allow_no_supp, extra_supps => \@extra_supps, ); @@ -84,6 +85,12 @@ Defaults to false. =item * +If C<$allow_no_supp> is true, the command will always be run into C even if no appropriate suppression file is available. + +Defaults to false. + +=item * + C<$extra_supps> is a reference to an array of optional suppression files that will be passed to C. Defaults to none. @@ -141,6 +148,7 @@ sub new { version => $version, regen_def_supp => delete($args{regen_def_supp}), no_def_supp => delete($args{no_def_supp}), + allow_no_supp => delete($args{allow_no_supp}), extra_supps => $extra_supps, }, $class; } @@ -182,9 +190,20 @@ Read-only accessor for the C option. Read-only accessor for the C option. +=head2 C + + my $allow_no_supp = $tvs->allow_no_supp; + +Read-only accessor for the C option. + =cut -eval "sub $_ { \$_[0]->{$_} }" for qw; +eval "sub $_ { \$_[0]->{$_} }" for qw< + valgrind + regen_def_supp + no_def_supp + allow_no_supp +>; =head2 C @@ -240,33 +259,48 @@ sub _run { my @supp_args; if ($self->do_suppressions) { push @supp_args, '--gen-suppressions=all'; - } elsif (not $self->no_def_supp) { - my $def_supp = $self->def_supp_file; - my $forced; - if ($self->regen_def_supp and -e $def_supp) { - 1 while unlink $def_supp; - $forced = 1; + } else { + if (!$self->no_def_supp) { + my $def_supp = $self->def_supp_file; + my $forced; + if ($self->regen_def_supp and -e $def_supp) { + 1 while unlink $def_supp; + $forced = 1; + } + if (defined $def_supp and not -e $def_supp) { + $self->report($self->report_class->new_diag( + 'Generating suppressions' . ($forced ? ' (forced)' : '') . '...' + )); + require Test::Valgrind::Suppressions; + Test::Valgrind::Suppressions->generate( + tool => $self->tool, + command => $self->command, + target => $def_supp, + ); + $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; + $self->report($self->report_class->new_diag( + "Suppressions for this perl stored in $def_supp" + )); + } } - if (defined $def_supp and not -e $def_supp) { + my @supp_files = grep { + -e $_ and $self->command->check_suppressions_file($_) + } $self->suppressions; + if (@supp_files > 1) { + my $files_list = join "\n", map " $_", @supp_files; $self->report($self->report_class->new_diag( - 'Generating suppressions' . ($forced ? ' (forced)' : '') . '...' + "Using suppressions from:\n$files_list" )); - require Test::Valgrind::Suppressions; - Test::Valgrind::Suppressions->generate( - tool => $self->tool, - command => $self->command, - target => $def_supp, - ); - $self->_croak('Couldn\'t generate suppressions') unless -e $def_supp; + } elsif (@supp_files) { $self->report($self->report_class->new_diag( - "Suppressions for this perl stored in $def_supp" + "Using suppressions from $supp_files[0]" )); + } elsif ($self->allow_no_supp) { + $self->report($self->report_class->new_diag("No suppressions used")); + } else { + $self->_croak("No compatible suppressions available"); } - for ($self->suppressions) { - next unless -e $_; - $self->report($self->report_class->new_diag("Using suppression file $_")); - push @supp_args, "--suppressions=$_"; - } + @supp_args = map "--suppressions=$_", @supp_files; } pipe my $vrdr, my $vwtr or $self->_croak("pipe(\$vrdr, \$vwtr): $!"); diff --git a/t/80-suppressions.t b/t/80-suppressions.t index bb93875..b2cfa8a 100644 --- 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'; diff --git a/t/supp/no_perl b/t/supp/no_perl new file mode 100644 index 0000000..9a32fec --- /dev/null +++ b/t/supp/no_perl @@ -0,0 +1,9 @@ +{ +PerlSuppression999 +Memcheck:Leak +match-leak-kinds: definite +fun:malloc +fun:calloc +fun:currentlocale +... +}