Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.

    perldoc Test::Valgrind::Command::Perl

package Test::Valgrind::Command::Perl;

use strict;
use warnings;

our $VERSION = '1.12';

use Env::Sanctify ();

use Test::Valgrind::Suppressions;

use base qw/Test::Valgrind::Command Test::Valgrind::Carp/;

sub new {
 my $class = shift;
 $class = ref($class) || $class;

 my %args = @_;

 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->{taint_mode} = $taint_mode;

 $self->{trainer_file} = $trainer_file;

 return $self;
}

sub new_trainer {
 my $self = shift;

 require File::Temp;
 my ($fh, $file) = File::Temp::tempfile(UNLINK => 0);
 {
  my $curpos = tell DATA;
  print $fh $_ while <DATA>;
  seek DATA, $curpos, 0;
 }
 close $fh or $self->_croak("close(tempscript): $!");

 $self->new(
  args         => [ '-MTest::Valgrind=run,1', $file ],
  trainer_file => $file,
  @_
 );
}

sub perl { $_[0]->{perl} }

sub inc { @{$_[0]->{inc} || []} }

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(@_);
}

sub env {
 Env::Sanctify->sanctify(
  env => {
   PERL_DESTRUCT_LEVEL => 3,
   PERL_DL_NONLAZY     => 1,
  },
 );
}

sub suppressions_tag {
 my ($self) = @_;

 unless (defined $self->{suppressions_tag}) {
  my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]);

  open my $pipe, '-|', $self->perl, '-V'
                     or $self->_croak('open("-| ' . $self->perl . " -V\"): $!");
  my $perl_v = do { local $/; <$pipe> };
  close $pipe or $self->_croak('close("-| ' . $self->perl . " -V\"): $!");

  require Digest::MD5;
  $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v);
 }

 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.*//s;
 $data = Test::Valgrind::Suppressions->strip_tail($session, $data);

 $report->new(
  id   => $report->id,
  kind => $report->kind,
  data => $data,
 );
}

sub DESTROY {
 my ($self) = @_;

 my $file = $self->{trainer_file};
 return unless $file and -e $file;

 1 while unlink $file;

 return;
}

1; # End of Test::Valgrind::Command::Perl

__DATA__
use strict;
use warnings;

BEGIN { require Test::Valgrind; }

use Test::More;

eval {
 require XSLoader;
 XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
};

unless ($@) {
 Test::Valgrind::notleak("valgrind it!");
} else {
 diag $@;
 *Test::Valgrind::DEBUGGING = sub { 'unknown' };
}

plan tests => 1;
fail 'should not be seen';
diag 'debbugging flag is ' . Test::Valgrind::DEBUGGING();

eval {
 require XSLoader;
 XSLoader::load('Test::Valgrind::Fake', 0);
};

diag $@ ? 'Ok' : 'Succeeded to load Test::Valgrind::Fake but should\'t';

require List::Util;

my @cards = List::Util::shuffle(0 .. 51);

{
 package Test::Valgrind::Test::Fake;

 use base qw/strict/;
}

eval 'use Time::HiRes qw/usleep/';