From: Vincent Pit <perl@profvince.com>
Date: Thu, 12 Nov 2015 21:58:16 +0000 (-0200)
Subject: Improve perl suppressions accuracy
X-Git-Tag: v1.16~2
X-Git-Url: http://git.vpit.fr/?a=commitdiff_plain;h=a08a925178ff4a5e8a68dc9ecc21d50c67049939;p=perl%2Fmodules%2FTest-Valgrind.git

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 8da4a0a..4669b23 100644
--- 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 55c8bab..939e1cc 100644
--- 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 7710e52..3e1fc31 100644
--- 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 bee6a0d..a125839 100644
--- 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 e3932ef..b46fce1 100644
--- 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 a57aca3..ba6056c 100644
--- 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/;
     }
    }
   }