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=a8e3e8d59f5fdcfbbadc8b90986ea109b3af03d6;hb=b34179155630f5f4cbea1749af4054a746ded9a4;hpb=abe419ac02d109283a1fe5615f5ab9d0a9a5572f diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm index a8e3e8d..9988295 100644 --- a/lib/Test/Valgrind/Command/Perl.pm +++ b/lib/Test/Valgrind/Command/Perl.pm @@ -9,33 +9,62 @@ Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl. =head1 VERSION -Version 1.01 +Version 1.17 =cut -our $VERSION = '1.01'; +our $VERSION = '1.17'; =head1 DESCRIPTION +This command is the base for all C-based commands. +It handles the suppression generation and sets the main command-line flags. + =cut +use List::Util (); use Env::Sanctify (); -use base qw/Test::Valgrind::Command Test::Valgrind::Carp/; +use Test::Valgrind::Suppressions; + +use base qw; =head1 METHODS This class inherits L. -=head2 C<< new perl => $^X, inc => \@INC, ... >> +=head2 C + + my $tvcp = Test::Valgrind::Command::Perl->new( + perl => $^X, + inc => \@INC, + taint_mode => $taint_mode, + %extra_args, + ); + +The package constructor, which takes several options : -Your usual constructor. +=over 4 + +=item * The C option specifies which C executable will run the arugment list given in C. -It defaults to C<$^X>. + +Defaults to C<$^X>. + +=item * C is a reference to an array of paths that will be passed as C<-I> to the invoked command. -It defaults to C<@INC>. + +Defaults to C<@INC>. + +=item * + +C<$taint_mode> is a boolean that specifies if the script should be run under taint mode. + +Defaults to false. + +=back Other arguments are passed straight to C<< Test::Valgrind::Command->new >>. @@ -47,16 +76,19 @@ sub new { my %args = @_; - my $perl = delete($args{perl}) || $^X; - my $inc = delete($args{inc}) || [ @INC ]; + my $perl = delete $args{perl} || $^X; + my $inc = delete $args{inc} || [ @INC ]; $class->_croak('Invalid INC list') unless ref $inc eq 'ARRAY'; + my $taint_mode = delete $args{taint_mode}; my $trainer_file = delete $args{trainer_file}; my $self = bless $class->SUPER::new(%args), $class; - $self->{perl} = $perl; - $self->{inc} = $inc; + $self->{perl} = $perl; + $self->{inc} = $inc; + $self->{taint_mode} = $taint_mode; + $self->{trainer_file} = $trainer_file; return $self; @@ -83,6 +115,8 @@ sub new_trainer { =head2 C + my $perl = $tvcp->perl; + Read-only accessor for the C option. =cut @@ -91,21 +125,36 @@ sub perl { $_[0]->{perl} } =head2 C + my @inc = $tvcp->inc; + Read-only accessor for the C option. =cut sub inc { @{$_[0]->{inc} || []} } +=head2 C + + my $taint_mode = $tvcp->taint_mode; + +Read-only accessor for the C option. + +=cut + +sub taint_mode { $_[0]->{taint_mode} } + sub args { my $self = shift; return $self->perl, + (('-T') x!! $self->taint_mode), map("-I$_", $self->inc), $self->SUPER::args(@_); } -=head2 C +=head2 C + + my $env = $tvcp->env($session); Returns an L object that sets the environment variables C to C<3> and C to C<1> during the run. @@ -114,7 +163,7 @@ Returns an L object that sets the environment variables Csanctify( env => { - PERL_DESTRUCT_LEVEL => 2, + PERL_DESTRUCT_LEVEL => 3, PERL_DL_NONLAZY => 1, }, ); @@ -138,6 +187,72 @@ 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 @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, + kind => $report->kind, + data => $data, + ); +} + sub DESTROY { my ($self) = @_; @@ -174,7 +289,7 @@ You can find documentation for this module with the perldoc command. =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. @@ -195,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; @@ -220,7 +335,7 @@ my @cards = List::Util::shuffle(0 .. 51); { package Test::Valgrind::Test::Fake; - use base qw/strict/; + use base qw; } -eval 'use Time::HiRes qw/usleep/'; +eval 'use Time::HiRes qw';