lib/Test/Valgrind/Command/Perl.pm

   1 package Test::Valgrind::Command::Perl;
   2
   3 use strict;
   4 use warnings;
   5
   6 =head1 NAME
   7
   8 Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.
   9
  10 =head1 VERSION
  11
  12 Version 1.14
  13
  14 =cut
  15
  16 our $VERSION = '1.14';
  17
  18 =head1 DESCRIPTION
  19
  20 This command is the base for all C<perl>-based commands.
  21 It handles the suppression generation and sets the main command-line flags.
  22
  23 =cut
  24
  25 use Env::Sanctify ();
  26
  27 use Test::Valgrind::Suppressions;
  28
  29 use base qw<Test::Valgrind::Command Test::Valgrind::Carp>;
  30
  31 =head1 METHODS
  32
  33 This class inherits L<Test::Valgrind::Command>.
  34
  35 =head2 C<new>
  36
  37     my $tvcp = Test::Valgrind::Command::Perl->new(
  38      perl       => $^X,
  39      inc        => \@INC,
  40      taint_mode => $taint_mode,
  41      %extra_args,
  42     );
  43
  44 The package constructor, which takes several options :
  45
  46 =over 4
  47
  48 =item *
  49
  50 The C<perl> option specifies which C<perl> executable will run the arugment list given in C<args>.
  51
  52 Defaults to C<$^X>.
  53
  54 =item *
  55
  56 C<inc> is a reference to an array of paths that will be passed as C<-I> to the invoked command.
  57
  58 Defaults to C<@INC>.
  59
  60 =item *
  61
  62 C<$taint_mode> is a boolean that specifies if the script should be run under taint mode.
  63
  64 Defaults to false.
  65
  66 =back
  67
  68 Other arguments are passed straight to C<< Test::Valgrind::Command->new >>.
  69
  70 =cut
  71
  72 sub new {
  73  my $class = shift;
  74  $class = ref($class) || $class;
  75
  76  my %args = @_;
  77
  78  my $perl       = delete $args{perl} || $^X;
  79  my $inc        = delete $args{inc}  || [ @INC ];
  80  $class->_croak('Invalid INC list') unless ref $inc eq 'ARRAY';
  81  my $taint_mode = delete $args{taint_mode};
  82
  83  my $trainer_file = delete $args{trainer_file};
  84
  85  my $self = bless $class->SUPER::new(%args), $class;
  86
  87  $self->{perl}       = $perl;
  88  $self->{inc}        = $inc;
  89  $self->{taint_mode} = $taint_mode;
  90
  91  $self->{trainer_file} = $trainer_file;
  92
  93  return $self;
  94 }
  95
  96 sub new_trainer {
  97  my $self = shift;
  98
  99  require File::Temp;
 100  my ($fh, $file) = File::Temp::tempfile(UNLINK => 0);
 101  {
 102   my $curpos = tell DATA;
 103   print $fh $_ while <DATA>;
 104   seek DATA, $curpos, 0;
 105  }
 106  close $fh or $self->_croak("close(tempscript): $!");
 107
 108  $self->new(
 109   args         => [ '-MTest::Valgrind=run,1', $file ],
 110   trainer_file => $file,
 111   @_
 112  );
 113 }
 114
 115 =head2 C<perl>
 116
 117     my $perl = $tvcp->perl;
 118
 119 Read-only accessor for the C<perl> option.
 120
 121 =cut
 122
 123 sub perl { $_[0]->{perl} }
 124
 125 =head2 C<inc>
 126
 127     my @inc = $tvcp->inc;
 128
 129 Read-only accessor for the C<inc> option.
 130
 131 =cut
 132
 133 sub inc { @{$_[0]->{inc} || []} }
 134
 135 =head2 C<taint_mode>
 136
 137     my $taint_mode = $tvcp->taint_mode;
 138
 139 Read-only accessor for the C<taint_mode> option.
 140
 141 =cut
 142
 143 sub taint_mode { $_[0]->{taint_mode} }
 144
 145 sub args {
 146  my $self = shift;
 147
 148  return $self->perl,
 149         (('-T') x!! $self->taint_mode),
 150         map("-I$_", $self->inc),
 151         $self->SUPER::args(@_);
 152 }
 153
 154 =head2 C<env>
 155
 156     my $env = $tvcp->env($session);
 157
 158 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.
 159
 160 =cut
 161
 162 sub env {
 163  Env::Sanctify->sanctify(
 164   env => {
 165    PERL_DESTRUCT_LEVEL => 3,
 166    PERL_DL_NONLAZY     => 1,
 167   },
 168  );
 169 }
 170
 171 sub suppressions_tag {
 172  my ($self) = @_;
 173
 174  unless (defined $self->{suppressions_tag}) {
 175   my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]);
 176
 177   open my $pipe, '-|', $self->perl, '-V'
 178                      or $self->_croak('open("-| ' . $self->perl . " -V\"): $!");
 179   my $perl_v = do { local $/; <$pipe> };
 180   close $pipe or $self->_croak('close("-| ' . $self->perl . " -V\"): $!");
 181
 182   require Digest::MD5;
 183   $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v);
 184  }
 185
 186  return $self->{suppressions_tag};
 187 }
 188
 189 sub filter {
 190  my ($self, $session, $report) = @_;
 191
 192  return $report if $report->is_diag
 193                 or not $report->isa('Test::Valgrind::Report::Suppressions');
 194
 195  my $data = $report->data;
 196  $data =~ s/[^\r\n]*\bPerl_runops_(?:standard|debug)\b.*//s;
 197  $data = Test::Valgrind::Suppressions->strip_tail($session, $data);
 198
 199  $report->new(
 200   id   => $report->id,
 201   kind => $report->kind,
 202   data => $data,
 203  );
 204 }
 205
 206 sub DESTROY {
 207  my ($self) = @_;
 208
 209  my $file = $self->{trainer_file};
 210  return unless $file and -e $file;
 211
 212  1 while unlink $file;
 213
 214  return;
 215 }
 216
 217 =head1 SEE ALSO
 218
 219 L<Test::Valgrind>, L<Test::Valgrind::Command>.
 220
 221 L<Env::Sanctify>.
 222
 223 =head1 AUTHOR
 224
 225 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 226
 227 You can contact me by mail or on C<irc.perl.org> (vincent).
 228
 229 =head1 BUGS
 230
 231 Please report any bugs or feature requests to C<bug-test-valgrind at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Valgrind>.
 232 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 233
 234 =head1 SUPPORT
 235
 236 You can find documentation for this module with the perldoc command.
 237
 238     perldoc Test::Valgrind::Command::Perl
 239
 240 =head1 COPYRIGHT & LICENSE
 241
 242 Copyright 2009,2010,2011,2013 Vincent Pit, all rights reserved.
 243
 244 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 245
 246 =cut
 247
 248 1; # End of Test::Valgrind::Command::Perl
 249
 250 __DATA__
 251 use strict;
 252 use warnings;
 253
 254 BEGIN { require Test::Valgrind; }
 255
 256 use Test::More;
 257
 258 eval {
 259  require XSLoader;
 260  XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
 261 };
 262
 263 unless ($@) {
 264  Test::Valgrind::notleak("valgrind it!");
 265 } else {
 266  diag $@;
 267  *Test::Valgrind::DEBUGGING = sub { 'unknown' };
 268 }
 269
 270 plan tests => 1;
 271 fail 'should not be seen';
 272 diag 'debbugging flag is ' . Test::Valgrind::DEBUGGING();
 273
 274 eval {
 275  require XSLoader;
 276  XSLoader::load('Test::Valgrind::Fake', 0);
 277 };
 278
 279 diag $@ ? 'Ok' : 'Succeeded to load Test::Valgrind::Fake but should\'t';
 280
 281 require List::Util;
 282
 283 my @cards = List::Util::shuffle(0 .. 51);
 284
 285 {
 286  package Test::Valgrind::Test::Fake;
 287
 288  use base qw<strict>;
 289 }
 290
 291 eval 'use Time::HiRes qw<usleep>';