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