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