1 package Test::Valgrind::Command::Perl;
8 Test::Valgrind::Command::Perl - A Test::Valgrind command that invokes perl.
16 our $VERSION = '1.16';
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.
28 use Test::Valgrind::Suppressions;
30 use base qw<Test::Valgrind::Command Test::Valgrind::Carp>;
34 This class inherits L<Test::Valgrind::Command>.
38 my $tvcp = Test::Valgrind::Command::Perl->new(
41 taint_mode => $taint_mode,
45 The package constructor, which takes several options :
51 The C<perl> option specifies which C<perl> executable will run the arugment list given in C<args>.
57 C<inc> is a reference to an array of paths that will be passed as C<-I> to the invoked command.
63 C<$taint_mode> is a boolean that specifies if the script should be run under taint mode.
69 Other arguments are passed straight to C<< Test::Valgrind::Command->new >>.
75 $class = ref($class) || $class;
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};
84 my $trainer_file = delete $args{trainer_file};
86 my $self = bless $class->SUPER::new(%args), $class;
88 $self->{perl} = $perl;
90 $self->{taint_mode} = $taint_mode;
92 $self->{trainer_file} = $trainer_file;
101 my ($fh, $file) = File::Temp::tempfile(UNLINK => 0);
103 my $curpos = tell DATA;
104 print $fh $_ while <DATA>;
105 seek DATA, $curpos, 0;
107 close $fh or $self->_croak("close(tempscript): $!");
110 args => [ '-MTest::Valgrind=run,1', $file ],
111 trainer_file => $file,
118 my $perl = $tvcp->perl;
120 Read-only accessor for the C<perl> option.
124 sub perl { $_[0]->{perl} }
128 my @inc = $tvcp->inc;
130 Read-only accessor for the C<inc> option.
134 sub inc { @{$_[0]->{inc} || []} }
138 my $taint_mode = $tvcp->taint_mode;
140 Read-only accessor for the C<taint_mode> option.
144 sub taint_mode { $_[0]->{taint_mode} }
150 (('-T') x!! $self->taint_mode),
151 map("-I$_", $self->inc),
152 $self->SUPER::args(@_);
157 my $env = $tvcp->env($session);
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.
164 Env::Sanctify->sanctify(
166 PERL_DESTRUCT_LEVEL => 3,
167 PERL_DL_NONLAZY => 1,
172 sub suppressions_tag {
175 unless (defined $self->{suppressions_tag}) {
176 my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]);
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\"): $!");
184 $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v);
187 return $self->{suppressions_tag};
190 sub check_suppressions_file {
191 my ($self, $file) = @_;
194 open my $fh, '<', $file or return 0;
198 return 1 if /^\s*fun:(Perl|S|XS)_/
209 my ($self, $session, $report) = @_;
211 return $report if $report->is_diag
212 or not $report->isa('Test::Valgrind::Report::Suppressions');
214 my @frames = grep length, split /\n/, $report->data;
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/
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);
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);
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);
243 $#frames = $top if defined $top;
245 my $data = join "\n", @frames, '';
247 $data = Test::Valgrind::Suppressions->maybe_generalize($session, $data);
251 kind => $report->kind,
259 my $file = $self->{trainer_file};
260 return unless $file and -e $file;
262 1 while unlink $file;
269 L<Test::Valgrind>, L<Test::Valgrind::Command>.
275 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
277 You can contact me by mail or on C<irc.perl.org> (vincent).
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.
286 You can find documentation for this module with the perldoc command.
288 perldoc Test::Valgrind::Command::Perl
290 =head1 COPYRIGHT & LICENSE
292 Copyright 2009,2010,2011,2013,2015 Vincent Pit, all rights reserved.
294 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
298 1; # End of Test::Valgrind::Command::Perl
304 BEGIN { require Test::Valgrind; }
310 XSLoader::load('Test::Valgrind', $Test::Valgrind::VERSION);
315 *Test::Valgrind::DEBUGGING = sub { 'unknown' };
317 Test::Valgrind::notleak("valgrind it!");
321 fail 'should not be seen';
322 diag 'debbugging flag is ' . Test::Valgrind::DEBUGGING();
326 XSLoader::load('Test::Valgrind::Fake', 0);
329 diag $@ ? 'Ok' : 'Succeeded to load Test::Valgrind::Fake but should\'t';
333 my @cards = List::Util::shuffle(0 .. 51);
336 package Test::Valgrind::Test::Fake;
341 eval 'use Time::HiRes qw<usleep>';