=head1 VERSION
-Version 1.11
+Version 1.18
=cut
-our $VERSION = '1.11';
+our $VERSION = '1.18';
=head1 DESCRIPTION
=cut
+use List::Util ();
use Env::Sanctify ();
-use base qw/Test::Valgrind::Command Test::Valgrind::Carp/;
+use Test::Valgrind::Suppressions;
+
+use base qw<Test::Valgrind::Command Test::Valgrind::Carp>;
=head1 METHODS
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 :
=head2 C<perl>
+ my $perl = $tvcp->perl;
+
Read-only accessor for the C<perl> option.
=cut
=head2 C<inc>
+ my @inc = $tvcp->inc;
+
Read-only accessor for the C<inc> option.
=cut
=head2 C<taint_mode>
+ my $taint_mode = $tvcp->taint_mode;
+
Read-only accessor for the C<taint_mode> option.
=cut
$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.
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.*//ms;
+ 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,
=head1 COPYRIGHT & LICENSE
-Copyright 2009 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.
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;
{
package Test::Valgrind::Test::Fake;
- use base qw/strict/;
+ use base qw<strict>;
}
-eval 'use Time::HiRes qw/usleep/';
+eval 'use Time::HiRes qw<usleep>';