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