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