X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Valgrind.git;a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FCommand%2FPerl.pm;h=99882955724f14a298f0791d62bc8721a9ee8b76;hp=bdc8ed390e082843baf1ea63624dd6b2e5aa9c21;hb=b34179155630f5f4cbea1749af4054a746ded9a4;hpb=44f0639e6ac34bdc0be52d47fe2c2df43ab1ca94

diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm
index bdc8ed3..9988295 100644
--- a/lib/Test/Valgrind/Command/Perl.pm
+++ b/lib/Test/Valgrind/Command/Perl.pm
@@ -9,11 +9,11 @@ Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.
 
 =head1 VERSION
 
-Version 1.12
+Version 1.17
 
 =cut
 
-our $VERSION = '1.12';
+our $VERSION = '1.17';
 
 =head1 DESCRIPTION
 
@@ -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;
@@ -32,7 +33,14 @@ use base qw<Test::Valgrind::Command Test::Valgrind::Carp>;
 
 This class inherits L<Test::Valgrind::Command>.
 
-=head2 C<< new perl => $^X, inc => \@INC, taint_mode => $taint_mode, ... >>
+=head2 C<new>
+
+    my $tvcp = Test::Valgrind::Command::Perl->new(
+     perl       => $^X,
+     inc        => \@INC,
+     taint_mode => $taint_mode,
+     %extra_args,
+    );
 
 The package constructor, which takes several options :
 
@@ -107,6 +115,8 @@ sub new_trainer {
 
 =head2 C<perl>
 
+    my $perl = $tvcp->perl;
+
 Read-only accessor for the C<perl> option.
 
 =cut
@@ -115,6 +125,8 @@ sub perl { $_[0]->{perl} }
 
 =head2 C<inc>
 
+    my @inc = $tvcp->inc;
+
 Read-only accessor for the C<inc> option.
 
 =cut
@@ -123,6 +135,8 @@ sub inc { @{$_[0]->{inc} || []} }
 
 =head2 C<taint_mode>
 
+    my $taint_mode = $tvcp->taint_mode;
+
 Read-only accessor for the C<taint_mode> option.
 
 =cut
@@ -138,7 +152,9 @@ sub args {
         $self->SUPER::args(@_);
 }
 
-=head2 C<env $session>
+=head2 C<env>
+
+    my $env = $tvcp->env($session);
 
 Returns an L<Env::Sanctify> object that sets the environment variables C<PERL_DESTRUCT_LEVEL> to C<3> and C<PERL_DL_NONLAZY> to C<1> during the run.
 
@@ -171,15 +187,64 @@ 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|S|XS)_/
+            or /^\s*obj:.*perl/;
+  }
+
+  close $fh;
+ }
+
+ return 0;
+}
+
 sub filter {
  my ($self, $session, $report) = @_;
 
  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,
@@ -224,7 +289,7 @@ You can find documentation for this module with the perldoc command.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2009,2010 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
 
 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 
@@ -245,11 +310,11 @@ eval {
  XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
 };
 
-unless ($@) {
- Test::Valgrind::notleak("valgrind it!");
-} else {
+if ($@) {
  diag $@;
  *Test::Valgrind::DEBUGGING = sub { 'unknown' };
+} else {
+ Test::Valgrind::notleak("valgrind it!");
 }
 
 plan tests => 1;