File Coverage

blib/lib/Test/Valgrind/Command/Perl.pm

Criterion	Covered	Total	%
statement	44	91	48.3
branch	4	30	13.3
condition	5	17	29.4
subroutine	14	21	66.6
pod	10	10	100.0
total	77	169	45.5

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

use strict;
use warnings;

=head1 NAME

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

=head1 VERSION

Version 1.17

=cut

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 Test::Valgrind::Suppressions;

use base qw;

=head1 METHODS

This class inherits L.

=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 :

=over 4

=item *

The C option specifies which C executable will run the arugment list given in C.

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.

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 >>.

=cut

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 ;
  seek DATA, $curpos, 0;
 }
 close $fh or $self->_croak("close(tempscript): $!");

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

=head2 C

    my $perl = $tvcp->perl;

Read-only accessor for the C option.

=cut

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

    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.

=cut

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

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

 1 while unlink $file;

 return;
}

=head1 SEE ALSO

L, L.

L.

=head1 AUTHOR

Vincent Pit, C<<  >>, L.

You can contact me by mail or on C (vincent).

=head1 BUGS

Please report any bugs or feature requests to C, or through the web interface at L.
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Test::Valgrind::Command::Perl

=head1 COPYRIGHT & LICENSE

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.

=cut

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

__DATA__