File Coverage

blib/lib/Test/Valgrind/Command/Perl.pm
Criterion Covered Total %
statement 44 91 48.3
branch 4 30 13.3
condition 5 17 29.4
subroutine 14 21 66.6
pod 10 10 100.0
total 77 169 45.5


line stmt bran cond sub pod time code
1             package Test::Valgrind::Command::Perl;
2              
3 4     4   20 use strict;
  4         8  
  4         112  
4 4     4   20 use warnings;
  4         10  
  4         202  
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-based commands.
21             It handles the suppression generation and sets the main command-line flags.
22              
23             =cut
24              
25 4     4   22 use List::Util ();
  4         6  
  4         58  
26 4     4   2740 use Env::Sanctify ();
  4         2038  
  4         92  
27              
28 4     4   2388 use Test::Valgrind::Suppressions;
  4         12  
  4         114  
29              
30 4     4   22 use base qw;
  4         8  
  4         5508  
31              
32             =head1 METHODS
33              
34             This class inherits L.
35              
36             =head2 C
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 option specifies which C executable will run the arugment list given in C.
52              
53             Defaults to C<$^X>.
54              
55             =item *
56              
57             C 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 4     4 1 6 my $class = shift;
75 4   33     28 $class = ref($class) || $class;
76              
77 4         14 my %args = @_;
78              
79 4   33     18 my $perl = delete $args{perl} || $^X;
80 4   50     38 my $inc = delete $args{inc} || [ @INC ];
81 4 50       24 $class->_croak('Invalid INC list') unless ref $inc eq 'ARRAY';
82 4         6 my $taint_mode = delete $args{taint_mode};
83              
84 4         8 my $trainer_file = delete $args{trainer_file};
85              
86 4         44 my $self = bless $class->SUPER::new(%args), $class;
87              
88 4         28 $self->{perl} = $perl;
89 4         8 $self->{inc} = $inc;
90 4         8 $self->{taint_mode} = $taint_mode;
91              
92 4         6 $self->{trainer_file} = $trainer_file;
93              
94 4         36 return $self;
95             }
96              
97             sub new_trainer {
98 0     0 1 0 my $self = shift;
99              
100 0         0 require File::Temp;
101 0         0 my ($fh, $file) = File::Temp::tempfile(UNLINK => 0);
102             {
103 0         0 my $curpos = tell DATA;
  0         0  
104 0         0 print $fh $_ while ;
105 0         0 seek DATA, $curpos, 0;
106             }
107 0 0       0 close $fh or $self->_croak("close(tempscript): $!");
108              
109 0         0 $self->new(
110             args => [ '-MTest::Valgrind=run,1', $file ],
111             trainer_file => $file,
112             @_
113             );
114             }
115              
116             =head2 C
117              
118             my $perl = $tvcp->perl;
119              
120             Read-only accessor for the C option.
121              
122             =cut
123              
124 2     2 1 21 sub perl { $_[0]->{perl} }
125              
126             =head2 C
127              
128             my @inc = $tvcp->inc;
129              
130             Read-only accessor for the C option.
131              
132             =cut
133              
134 2 50   2 1 14 sub inc { @{$_[0]->{inc} || []} }
  2         301  
135              
136             =head2 C
137              
138             my $taint_mode = $tvcp->taint_mode;
139              
140             Read-only accessor for the C option.
141              
142             =cut
143              
144 2     2 1 40 sub taint_mode { $_[0]->{taint_mode} }
145              
146             sub args {
147 2     2 1 7 my $self = shift;
148              
149 2         53 return $self->perl,
150             (('-T') x!! $self->taint_mode),
151             map("-I$_", $self->inc),
152             $self->SUPER::args(@_);
153             }
154              
155             =head2 C
156              
157             my $env = $tvcp->env($session);
158              
159             Returns an L object that sets the environment variables C to C<3> and C to C<1> during the run.
160              
161             =cut
162              
163             sub env {
164 6     6 1 138 Env::Sanctify->sanctify(
165             env => {
166             PERL_DESTRUCT_LEVEL => 3,
167             PERL_DL_NONLAZY => 1,
168             },
169             );
170             }
171              
172             sub suppressions_tag {
173 0     0 1 0 my ($self) = @_;
174              
175 0 0       0 unless (defined $self->{suppressions_tag}) {
176 0         0 my $env = Env::Sanctify->sanctify(sanctify => [ qr/^PERL/ ]);
177              
178 0 0       0 open my $pipe, '-|', $self->perl, '-V'
179             or $self->_croak('open("-| ' . $self->perl . " -V\"): $!");
180 0         0 my $perl_v = do { local $/; <$pipe> };
  0         0  
  0         0  
181 0 0       0 close $pipe or $self->_croak('close("-| ' . $self->perl . " -V\"): $!");
182              
183 0         0 require Digest::MD5;
184 0         0 $self->{suppressions_tag} = Digest::MD5::md5_hex($perl_v);
185             }
186              
187 0         0 return $self->{suppressions_tag};
188             }
189              
190             sub check_suppressions_file {
191 0     0 1 0 my ($self, $file) = @_;
192              
193             {
194 0 0       0 open my $fh, '<', $file or return 0;
  0         0  
195              
196 0         0 local $_;
197 0         0 while (<$fh>) {
198 0 0 0     0 return 1 if /^\s*fun:(Perl|S|XS)_/
199             or /^\s*obj:.*perl/;
200             }
201              
202 0         0 close $fh;
203             }
204              
205 0         0 return 0;
206             }
207              
208             sub filter {
209 10     10 1 30 my ($self, $session, $report) = @_;
210              
211 10 50 33     84 return $report if $report->is_diag
212             or not $report->isa('Test::Valgrind::Report::Suppressions');
213              
214 0         0 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 0     0   0 $frames[$_] =~ /^\s*fun:Perl_runops_(?:standard|debug)\b/
219 0         0 }, 0 .. $#frames);
220 0 0       0 --$top if $top;
221              
222 0 0       0 unless (defined $top) {
223             # Otherwise, match from the latest Perl_ symbol.
224             $top = List::Util::first(sub {
225 0     0   0 $frames[$_] =~ /^\s*fun:Perl_/
226 0         0 }, reverse 0 .. $#frames);
227             }
228              
229 0 0       0 unless (defined $top) {
230             # Otherwise, match from the latest S_ symbol.
231             $top = List::Util::first(sub {
232 0     0   0 $frames[$_] =~ /^\s*fun:S_/
233 0         0 }, reverse 0 .. $#frames);
234             }
235              
236 0 0       0 unless (defined $top) {
237             # Otherwise, match from the latest XS_ symbol.
238             $top = List::Util::first(sub {
239 0     0   0 $frames[$_] =~ /^\s*fun:XS_/
240 0         0 }, reverse 0 .. $#frames);
241             }
242              
243 0 0       0 $#frames = $top if defined $top;
244              
245 0         0 my $data = join "\n", @frames, '';
246              
247 0         0 $data = Test::Valgrind::Suppressions->maybe_generalize($session, $data);
248              
249 0         0 $report->new(
250             id => $report->id,
251             kind => $report->kind,
252             data => $data,
253             );
254             }
255              
256             sub DESTROY {
257 2     2   2064 my ($self) = @_;
258              
259 2         8 my $file = $self->{trainer_file};
260 2 50 33     205 return unless $file and -e $file;
261              
262 0           1 while unlink $file;
263              
264 0           return;
265             }
266              
267             =head1 SEE ALSO
268              
269             L, L.
270              
271             L.
272              
273             =head1 AUTHOR
274              
275             Vincent Pit, C<< >>, L.
276              
277             You can contact me by mail or on C (vincent).
278              
279             =head1 BUGS
280              
281             Please report any bugs or feature requests to C, or through the web interface at L.
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__