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