]> git.vpit.fr Git - perl/modules/Test-Valgrind.git/blob - Perl.pm
f6c1ede2ef8bf205a43a0696c69ae382532b5cd1
[perl/modules/Test-Valgrind.git] / 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.11
13
14 =cut
15
16 our $VERSION = '1.11';
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/';