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