X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FValgrind%2FCommand%2FPerl.pm;h=9178a926ffc558f422b2e5e232685200d09fb91a;hb=08860dad1f820cce06758ec4add9353a4dbc8175;hp=091f7509c563afde8849368e0c548d7977d6e6a3;hpb=b41c498738a3a4ccb8742883a42e6ea5addb1afd;p=perl%2Fmodules%2FTest-Valgrind.git

diff --git a/lib/Test/Valgrind/Command/Perl.pm b/lib/Test/Valgrind/Command/Perl.pm
index 091f750..9178a92 100644
--- a/lib/Test/Valgrind/Command/Perl.pm
+++ b/lib/Test/Valgrind/Command/Perl.pm
@@ -9,14 +9,17 @@ Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.
 
 =head1 VERSION
 
-Version 1.00
+Version 1.10
 
 =cut
 
-our $VERSION = '1.00';
+our $VERSION = '1.10';
 
 =head1 DESCRIPTION
 
+This command is the base for all C<perl>-based commands.
+It handles the suppression generation and sets the main command-line flags.
+
 =cut
 
 use Env::Sanctify ();
@@ -27,15 +30,31 @@ use base qw/Test::Valgrind::Command Test::Valgrind::Carp/;
 
 This class inherits L<Test::Valgrind::Command>.
 
-=head2 C<< new perl => $^X, inc => \@INC, ... >>
+=head2 C<< new perl => $^X, inc => \@INC, taint_mode => $taint_mode, ... >>
+
+The package constructor, which takes several options :
+
+=over 4
 
-Your usual constructor.
+=item *
 
 The C<perl> option specifies which C<perl> executable will run the arugment list given in C<args>.
-It defaults to C<$^X>.
+
+Defaults to C<$^X>.
+
+=item *
 
 C<inc> 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 +66,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;
@@ -97,10 +119,19 @@ Read-only accessor for the C<inc> option.
 
 sub inc { @{$_[0]->{inc} || []} }
 
+=head2 C<taint_mode>
+
+Read-only accessor for the C<taint_mode> 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(@_);
 }
@@ -138,6 +169,22 @@ sub suppressions_tag {
  return $self->{suppressions_tag};
 }
 
+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;
+
+ $report->new(
+  id   => $report->id,
+  kind => $report->kind,
+  data => $data,
+ );
+}
+
 sub DESTROY {
  my ($self) = @_;