Improve perl suppressions accuracy

We achieve this by allowing more ellipsis frames, by reworking how the
suppressions are anchored to perl related symbols, and also by increasing
the default number of callers at analysis time to match the one used
at suppression time.

diff --git a/lib/Test/Valgrind.pm b/lib/Test/Valgrind.pm
index 8da4a0a50b7da9e08c942c46b0fee842a0c3714b..4669b23bd7bcdeae65ebeb8ca879e82b56c0330a 100644 (file)
--- a/lib/Test/Valgrind.pm
+++ b/lib/Test/Valgrind.pm
@@ -96,7 +96,7 @@ C<< callers => $number >>
 Specify the maximum stack depth studied when valgrind encounters an error.
 Raising this number improves granularity.
 
-Ignored if you supply your own custom C<tool>, otherwise defaults to C<12>.
+Ignored if you supply your own custom C<tool>, otherwise defaults to C<50>.
 
 =item *
 

diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm
index 55c8babe5bb48e99eace1bf5148dd600cd756900..939e1ccc86f9f66d13b058a01d5ff78c3802c564 100644 (file)
--- a/lib/Test/Valgrind/Command/Perl.pm
+++ b/lib/Test/Valgrind/Command/Perl.pm
@@ -22,6 +22,7 @@ It handles the suppression generation and sets the main command-line flags.
 
 =cut
 
+use List::Util    ();
 use Env::Sanctify ();
 
 use Test::Valgrind::Suppressions;
@@ -194,7 +195,8 @@ sub check_suppressions_file {
 
   local $_;
   while (<$fh>) {
-   return 1 if /^\s*fun:Perl_/;
+   return 1 if /^\s*fun:(Perl|S|XS)_/
+            or /^\s*obj:.*perl/;
   }
 
   close $fh;
@@ -209,9 +211,40 @@ sub filter {
  return $report if $report->is_diag
                 or not $report->isa('Test::Valgrind::Report::Suppressions');
 
- my $data = $report->data;
- $data =~ s/[^\r\n]*\bPerl_runops_(?:standard|debug)\b.*//s;
- $data = Test::Valgrind::Suppressions->strip_tail($session, $data);
+ my @frames = grep length, split /\n/, $report->data;
+
+ # If we see the runloop, match from here.
+ my $top = List::Util::first(sub {
+  $frames[$_] =~ /^\s*fun:Perl_runops_(?:standard|debug)\b/
+ }, 0 .. $#frames);
+ --$top if $top;
+
+ unless (defined $top) {
+  # Otherwise, match from the latest Perl_ symbol.
+  $top = List::Util::first(sub {
+   $frames[$_] =~ /^\s*fun:Perl_/
+  }, reverse 0 .. $#frames);
+ }
+
+ unless (defined $top) {
+  # Otherwise, match from the latest S_ symbol.
+  $top = List::Util::first(sub {
+   $frames[$_] =~ /^\s*fun:S_/
+  }, reverse 0 .. $#frames);
+ }
+
+ unless (defined $top) {
+  # Otherwise, match from the latest XS_ symbol.
+  $top = List::Util::first(sub {
+   $frames[$_] =~ /^\s*fun:XS_/
+  }, reverse 0 .. $#frames);
+ }
+
+ $#frames = $top if defined $top;
+
+ my $data = join "\n", @frames, '';
+
+ $data = Test::Valgrind::Suppressions->maybe_generalize($session, $data);
 
  $report->new(
   id   => $report->id,

diff --git a/lib/Test/Valgrind/Parser/Suppressions/Text.pm b/lib/Test/Valgrind/Parser/Suppressions/Text.pm
index 7710e524d40722abec62c097955db45b6c4b7534..3e1fc31579e7a8a686790a98d271b033c1184700 100644 (file)
--- a/lib/Test/Valgrind/Parser/Suppressions/Text.pm
+++ b/lib/Test/Valgrind/Parser/Suppressions/Text.pm
@@ -61,7 +61,6 @@ sub parse {
   if ($_ eq '{') {      # A suppression block begins
    $in = 1;
   } elsif ($_ eq '}') { # A suppression block ends
-   $s = Test::Valgrind::Suppressions->strip_tail($sess, $s); # Strip the tail
    push @supps, $s;     # Add the suppression that just ended to the list
    $s  = '';            # Reset the state
    $in = 0;

diff --git a/lib/Test/Valgrind/Suppressions.pm b/lib/Test/Valgrind/Suppressions.pm
index bee6a0dd45a3e7e840b3782b0807998a8cc7e030..a125839a6dff017fee51fd0e9804c66c7ebd80e0 100644 (file)
--- a/lib/Test/Valgrind/Suppressions.pm
+++ b/lib/Test/Valgrind/Suppressions.pm
@@ -94,29 +94,30 @@ sub generate {
  return $status;
 }
 
-=head2 C<strip_tail>
+=head2 C<maybe_generalize>
 
-    my $mangled_suppression = Test::Valgrind::Suppressions->strip_tail(
+    my $mangled_suppression = Test::Valgrind::Suppressions->maybe_generalize(
      $session,
      $suppression,
     );
 
 Removes all wildcard frames at the end of the suppression.
-Moreover, C<'...'> is appended when C<valgrind> C<3.4.0> or higher is used.
+It also replaces sequences of wildcard frames by C<'...'> when C<valgrind> C<3.4.0> or higher is used.
 Returns the mangled suppression.
 
 =cut
 
-sub strip_tail {
+sub maybe_generalize {
  shift;
 
  my ($sess, $supp) = @_;
 
  1 while $supp =~ s/[^\r\n]*:\s*\*\s*$//;
+
  # With valgrind 3.4.0, we can replace unknown series of frames by '...'
  if ($sess->version ge '3.4.0') {
-  1 while $supp =~ s/[^\r\n]*\.{3}\s*$//;
   $supp .= "...\n";
+  $supp =~ s/(?:^\s*(?:\.{3}|\*:\S*|obj:\*)\s*\n)+/...\n/mg;
  }
 
  $supp;

diff --git a/lib/Test/Valgrind/Tool/memcheck.pm b/lib/Test/Valgrind/Tool/memcheck.pm
index e3932ef079fd18f4096c04ba5ed1a7dd955c9add..b46fce1846ae62ff985806dff6cdb8fd0a07b59b 100644 (file)
--- a/lib/Test/Valgrind/Tool/memcheck.pm
+++ b/lib/Test/Valgrind/Tool/memcheck.pm
@@ -58,7 +58,7 @@ sub new {
 
  my %args = @_;
 
- my $callers = delete $args{callers} || 12;
+ my $callers = delete $args{callers} || 50;
  $callers =~ s/\D//g;
 
  my $self = bless $class->Test::Valgrind::Tool::new(%args), $class;

diff --git a/t/80-suppressions.t b/t/80-suppressions.t
index a57aca3a08a26831cc25d53d1626b6f2f2e18149..ba6056cae573f6a78260de22790c8f5f0ebaae03 100644 (file)
--- a/t/80-suppressions.t
+++ b/t/80-suppressions.t
@@ -102,7 +102,8 @@ SKIP: {
      $in = 0;
     } else {
      ++$valid_frames if /^\s*fun:/;
-     ++$seen_perl    if /^\s*fun:Perl_/;
+     ++$seen_perl    if /^\s*fun:(Perl|S|XS)_/
+                     or /^\s*obj:.*perl/;
     }
    }
   }