Commit | Line | Data |
b965d173 |
1 | package TAP::Parser::Source::Perl; |
2 | |
3 | use strict; |
4 | use Config; |
5 | use vars qw($VERSION @ISA); |
6 | |
7 | use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); |
8 | use constant IS_VMS => ( $^O eq 'VMS' ); |
9 | |
10 | use TAP::Parser::Source; |
27fc0087 |
11 | use TAP::Parser::Utils qw( split_shell ); |
12 | |
b965d173 |
13 | @ISA = 'TAP::Parser::Source'; |
14 | |
15 | =head1 NAME |
16 | |
17 | TAP::Parser::Source::Perl - Stream Perl output |
18 | |
19 | =head1 VERSION |
20 | |
a39e16d8 |
21 | Version 3.17 |
b965d173 |
22 | |
23 | =cut |
24 | |
a39e16d8 |
25 | $VERSION = '3.17'; |
f7c69158 |
26 | |
27 | =head1 SYNOPSIS |
28 | |
29 | use TAP::Parser::Source::Perl; |
30 | my $perl = TAP::Parser::Source::Perl->new; |
31 | my $stream = $perl->source( [ $filename, @args ] )->get_stream; |
b965d173 |
32 | |
33 | =head1 DESCRIPTION |
34 | |
35 | Takes a filename and hopefully returns a stream from it. The filename should |
36 | be the name of a Perl program. |
37 | |
38 | Note that this is a subclass of L<TAP::Parser::Source>. See that module for |
39 | more methods. |
40 | |
b965d173 |
41 | =head1 METHODS |
42 | |
43 | =head2 Class Methods |
44 | |
45 | =head3 C<new> |
46 | |
47 | my $perl = TAP::Parser::Source::Perl->new; |
48 | |
49 | Returns a new C<TAP::Parser::Source::Perl> object. |
50 | |
51 | =head2 Instance Methods |
52 | |
53 | =head3 C<source> |
54 | |
55 | Getter/setter the name of the test program and any arguments it requires. |
56 | |
57 | my ($filename, @args) = @{ $perl->source }; |
58 | $perl->source( [ $filename, @args ] ); |
59 | |
f7c69158 |
60 | C<croak>s if C<$filename> could not be found. |
61 | |
b965d173 |
62 | =cut |
63 | |
64 | sub source { |
65 | my $self = shift; |
66 | $self->_croak("Cannot find ($_[0][0])") |
67 | if @_ && !-f $_[0][0]; |
68 | return $self->SUPER::source(@_); |
69 | } |
70 | |
71 | =head3 C<switches> |
72 | |
73 | my $switches = $perl->switches; |
74 | my @switches = $perl->switches; |
75 | $perl->switches( \@switches ); |
76 | |
77 | Getter/setter for the additional switches to pass to the perl executable. One |
78 | common switch would be to set an include directory: |
79 | |
80 | $perl->switches( ['-Ilib'] ); |
81 | |
82 | =cut |
83 | |
84 | sub switches { |
85 | my $self = shift; |
86 | unless (@_) { |
87 | return wantarray ? @{ $self->{switches} } : $self->{switches}; |
88 | } |
89 | my $switches = shift; |
90 | $self->{switches} = [@$switches]; # force a copy |
91 | return $self; |
92 | } |
93 | |
94 | ############################################################################## |
95 | |
96 | =head3 C<get_stream> |
97 | |
f7c69158 |
98 | my $stream = $source->get_stream($parser); |
b965d173 |
99 | |
f7c69158 |
100 | Returns a stream of the output generated by executing C<source>. Must be |
101 | passed an object that implements a C<make_iterator> method. Typically |
102 | this is a TAP::Parser instance. |
b965d173 |
103 | |
104 | =cut |
105 | |
106 | sub get_stream { |
f7c69158 |
107 | my ( $self, $factory ) = @_; |
b965d173 |
108 | |
b965d173 |
109 | my @switches = $self->_switches; |
110 | my $path_sep = $Config{path_sep}; |
111 | my $path_pat = qr{$path_sep}; |
112 | |
bdaf8c65 |
113 | # Filter out any -I switches to be handled as libs later. |
114 | # |
b965d173 |
115 | # Nasty kludge. It might be nicer if we got the libs separately |
116 | # although at least this way we find any -I switches that were |
117 | # supplied other then as explicit libs. |
bdaf8c65 |
118 | # |
b965d173 |
119 | # We filter out any names containing colons because they will break |
120 | # PERL5LIB |
121 | my @libs; |
bdaf8c65 |
122 | my @filtered_switches; |
123 | for (@switches) { |
124 | if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { |
125 | push @libs, $1; |
126 | } |
127 | else { |
128 | push @filtered_switches, $_; |
129 | } |
b965d173 |
130 | } |
bdaf8c65 |
131 | @switches = @filtered_switches; |
b965d173 |
132 | |
133 | my $setup = sub { |
134 | if (@libs) { |
bdaf8c65 |
135 | $ENV{PERL5LIB} |
136 | = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} ); |
b965d173 |
137 | } |
138 | }; |
139 | |
140 | # Cargo culted from comments seen elsewhere about VMS / environment |
141 | # variables. I don't know if this is actually necessary. |
bdaf8c65 |
142 | my $previous = $ENV{PERL5LIB}; |
b965d173 |
143 | my $teardown = sub { |
bdaf8c65 |
144 | if ( defined $previous ) { |
b965d173 |
145 | $ENV{PERL5LIB} = $previous; |
146 | } |
147 | else { |
148 | delete $ENV{PERL5LIB}; |
149 | } |
150 | }; |
151 | |
152 | # Taint mode ignores environment variables so we must retranslate |
153 | # PERL5LIB as -I switches and place PERL5OPT on the command line |
154 | # in order that it be seen. |
27fc0087 |
155 | if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) { |
bdaf8c65 |
156 | push @switches, $self->_libs2switches(@libs); |
27fc0087 |
157 | push @switches, split_shell( $ENV{PERL5OPT} ); |
b965d173 |
158 | } |
159 | |
160 | my @command = $self->_get_command_for_switches(@switches) |
161 | or $self->_croak("No command found!"); |
162 | |
f7c69158 |
163 | return $factory->make_iterator( |
b965d173 |
164 | { command => \@command, |
165 | merge => $self->merge, |
166 | setup => $setup, |
167 | teardown => $teardown, |
168 | } |
169 | ); |
170 | } |
171 | |
172 | sub _get_command_for_switches { |
173 | my $self = shift; |
174 | my @switches = @_; |
175 | my ( $file, @args ) = @{ $self->source }; |
176 | my $command = $self->_get_perl; |
177 | |
f7c69158 |
178 | # XXX we never need to quote if we treat the parts as atoms (except maybe vms) |
179 | #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); |
b965d173 |
180 | my @command = ( $command, @switches, $file, @args ); |
181 | return @command; |
182 | } |
183 | |
184 | sub _get_command { |
185 | my $self = shift; |
186 | return $self->_get_command_for_switches( $self->_switches ); |
187 | } |
188 | |
189 | sub _libs2switches { |
190 | my $self = shift; |
191 | return map {"-I$_"} grep {$_} @_; |
192 | } |
193 | |
194 | =head3 C<shebang> |
195 | |
196 | Get the shebang line for a script file. |
197 | |
f7c69158 |
198 | my $shebang = TAP::Parser::Source::Perl->shebang( $some_script ); |
b965d173 |
199 | |
200 | May be called as a class method |
201 | |
202 | =cut |
203 | |
204 | { |
205 | |
206 | # Global shebang cache. |
207 | my %shebang_for; |
208 | |
209 | sub _read_shebang { |
210 | my $file = shift; |
211 | local *TEST; |
212 | my $shebang; |
213 | if ( open( TEST, $file ) ) { |
214 | $shebang = <TEST>; |
215 | close(TEST) or print "Can't close $file. $!\n"; |
216 | } |
217 | else { |
218 | print "Can't open $file. $!\n"; |
219 | } |
220 | return $shebang; |
221 | } |
222 | |
223 | sub shebang { |
224 | my ( $class, $file ) = @_; |
225 | unless ( exists $shebang_for{$file} ) { |
226 | $shebang_for{$file} = _read_shebang($file); |
227 | } |
228 | return $shebang_for{$file}; |
229 | } |
230 | } |
231 | |
232 | =head3 C<get_taint> |
233 | |
234 | Decode any taint switches from a Perl shebang line. |
235 | |
f7c69158 |
236 | # $taint will be 't' |
237 | my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' ); |
b965d173 |
238 | |
f7c69158 |
239 | # $untaint will be undefined |
240 | my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' ); |
b965d173 |
241 | |
242 | =cut |
243 | |
244 | sub get_taint { |
245 | my ( $class, $shebang ) = @_; |
246 | return |
247 | unless defined $shebang |
248 | && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; |
249 | return $1; |
250 | } |
251 | |
252 | sub _switches { |
253 | my $self = shift; |
254 | my ( $file, @args ) = @{ $self->source }; |
255 | my @switches = ( |
256 | $self->switches, |
257 | ); |
258 | |
259 | my $shebang = $self->shebang($file); |
260 | return unless defined $shebang; |
261 | |
262 | my $taint = $self->get_taint($shebang); |
263 | push @switches, "-$taint" if defined $taint; |
264 | |
bdaf8c65 |
265 | # Quote the argument if we're VMS, since VMS will downcase anything |
266 | # not quoted. |
267 | if (IS_VMS) { |
268 | for (@switches) { |
269 | $_ = qq["$_"]; |
270 | } |
b965d173 |
271 | } |
272 | |
b965d173 |
273 | return @switches; |
274 | } |
275 | |
276 | sub _get_perl { |
f7c69158 |
277 | my $self = shift; |
69f36734 |
278 | return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; |
b965d173 |
279 | return Win32::GetShortPathName($^X) if IS_WIN32; |
280 | return $^X; |
281 | } |
282 | |
283 | 1; |
f7c69158 |
284 | |
285 | =head1 SUBCLASSING |
286 | |
287 | Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. |
288 | |
289 | =head2 Example |
290 | |
291 | package MyPerlSource; |
292 | |
293 | use strict; |
294 | use vars '@ISA'; |
295 | |
296 | use Carp qw( croak ); |
297 | use TAP::Parser::Source::Perl; |
298 | |
299 | @ISA = qw( TAP::Parser::Source::Perl ); |
300 | |
301 | sub source { |
302 | my ($self, $args) = @_; |
303 | if ($args) { |
304 | $self->{file} = $args->[0]; |
305 | return $self->SUPER::source($args); |
306 | } |
307 | return $self->SUPER::source; |
308 | } |
309 | |
310 | # use the version of perl from the shebang line in the test file |
311 | sub _get_perl { |
312 | my $self = shift; |
313 | if (my $shebang = $self->shebang( $self->{file} )) { |
314 | $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; |
315 | return $1 if $1; |
316 | } |
317 | return $self->SUPER::_get_perl(@_); |
318 | } |
319 | |
320 | =head1 SEE ALSO |
321 | |
322 | L<TAP::Object>, |
323 | L<TAP::Parser>, |
324 | L<TAP::Parser::Source>, |
325 | |
326 | =cut |