Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Parser / SourceHandler / Perl.pm
1 package TAP::Parser::SourceHandler::Perl;
2
3 use strict;
4 use warnings;
5 use Config;
6
7 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
8 use constant IS_VMS => ( $^O eq 'VMS' );
9
10 use TAP::Parser::IteratorFactory           ();
11 use TAP::Parser::Iterator::Process         ();
12 use Text::ParseWords qw(shellwords);
13
14 use base 'TAP::Parser::SourceHandler::Executable';
15
16 TAP::Parser::IteratorFactory->register_handler(__PACKAGE__);
17
18 =head1 NAME
19
20 TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable
21
22 =head1 VERSION
23
24 Version 3.39
25
26 =cut
27
28 our $VERSION = '3.39';
29
30 =head1 SYNOPSIS
31
32   use TAP::Parser::Source;
33   use TAP::Parser::SourceHandler::Perl;
34
35   my $source = TAP::Parser::Source->new->raw( \'script.pl' );
36   $source->assemble_meta;
37
38   my $class = 'TAP::Parser::SourceHandler::Perl';
39   my $vote  = $class->can_handle( $source );
40   my $iter  = $class->make_iterator( $source );
41
42 =head1 DESCRIPTION
43
44 This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs:
45
46 1. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl
47 script (L</can_handle>).
48
49 2. Creates an iterator for Perl sources (L</make_iterator>).
50
51 Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably
52 won't need to use this module directly.
53
54 =head1 METHODS
55
56 =head2 Class Methods
57
58 =head3 C<can_handle>
59
60   my $vote = $class->can_handle( $source );
61
62 Only votes if $source looks like a file.  Casts the following votes:
63
64   0.9  if it has a shebang ala "#!...perl"
65   0.75 if it has any shebang
66   0.8  if it's a .t file
67   0.9  if it's a .pl file
68   0.75 if it's in a 't' directory
69   0.25 by default (backwards compat)
70
71 =cut
72
73 sub can_handle {
74     my ( $class, $source ) = @_;
75     my $meta = $source->meta;
76
77     return 0 unless $meta->{is_file};
78     my $file = $meta->{file};
79
80     if ( my $shebang = $file->{shebang} ) {
81         return 0.9 if $shebang =~ /^#!.*\bperl/;
82
83         # We favour Perl as the interpreter for any shebang to preserve
84         # previous semantics: we used to execute everything via Perl and
85         # relied on it to pass the shebang off to the appropriate
86         # interpreter.
87         return 0.3;
88     }
89
90     return 0.8 if $file->{lc_ext} eq '.t';    # vote higher than Executable
91     return 0.9 if $file->{lc_ext} eq '.pl';
92
93     return 0.75 if $file->{dir} =~ /^t\b/;    # vote higher than Executable
94
95     # backwards compat, always vote:
96     return 0.25;
97 }
98
99 =head3 C<make_iterator>
100
101   my $iterator = $class->make_iterator( $source );
102
103 Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source.
104 Assumes C<$source-E<gt>raw> contains a reference to the perl script.  C<croak>s
105 if the file could not be found.
106
107 The command to run is built as follows:
108
109   $perl @switches $perl_script @test_args
110
111 The perl command to use is determined by L</get_perl>.  The command generated
112 is guaranteed to preserve:
113
114   PERL5LIB
115   PERL5OPT
116   Taint Mode, if set in the script's shebang
117
118 I<Note:> the command generated will I<not> respect any shebang line defined in
119 your Perl script.  This is only a problem if you have compiled a custom version
120 of Perl or if you want to use a specific version of Perl for one test and a
121 different version for another, for example:
122
123   #!/path/to/a/custom_perl --some --args
124   #!/usr/local/perl-5.6/bin/perl -w
125
126 Currently you need to write a plugin to get around this.
127
128 =cut
129
130 sub _autoflush_stdhandles {
131     my ($class) = @_;
132
133     $class->_autoflush( \*STDOUT );
134     $class->_autoflush( \*STDERR );
135 }
136
137 sub make_iterator {
138     my ( $class, $source ) = @_;
139     my $meta        = $source->meta;
140     my $perl_script = ${ $source->raw };
141
142     $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file};
143
144     # TODO: does this really need to be done here?
145     $class->_autoflush_stdhandles;
146
147     my ( $libs, $switches )
148       = $class->_mangle_switches(
149         $class->_filter_libs( $class->_switches($source) ) );
150
151     $class->_run( $source, $libs, $switches );
152 }
153
154
155 sub _has_taint_switch {
156     my( $class, $switches ) = @_;
157
158     my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches};
159     return $has_taint ? 1 : 0;
160 }
161
162 sub _mangle_switches {
163     my ( $class, $libs, $switches ) = @_;
164
165     # Taint mode ignores environment variables so we must retranslate
166     # PERL5LIB as -I switches and place PERL5OPT on the command line
167     # in order that it be seen.
168     if ( $class->_has_taint_switch($switches) ) {
169         my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : ();
170         return (
171             $libs,
172             [   @{$switches},
173                 $class->_libs2switches([@$libs, @perl5lib]),
174                 defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : ()
175             ],
176         );
177     }
178
179     return ( $libs, $switches );
180 }
181
182 sub _filter_libs {
183     my ( $class, @switches ) = @_;
184
185     my $path_sep = $Config{path_sep};
186     my $path_re  = qr{$path_sep};
187
188     # Filter out any -I switches to be handled as libs later.
189     #
190     # Nasty kludge. It might be nicer if we got the libs separately
191     # although at least this way we find any -I switches that were
192     # supplied other then as explicit libs.
193     #
194     # We filter out any names containing colons because they will break
195     # PERL5LIB
196     my @libs;
197     my @filtered_switches;
198     for (@switches) {
199         if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
200             push @libs, $1;
201         }
202         else {
203             push @filtered_switches, $_;
204         }
205     }
206
207     return \@libs, \@filtered_switches;
208 }
209
210 sub _iterator_hooks {
211     my ( $class, $source, $libs, $switches ) = @_;
212
213     my $setup = sub {
214         if ( @{$libs} and !$class->_has_taint_switch($switches) ) {
215             $ENV{PERL5LIB} = join(
216                 $Config{path_sep}, grep {defined} @{$libs},
217                 $ENV{PERL5LIB}
218             );
219         }
220     };
221
222     # VMS environment variables aren't guaranteed to reset at the end of
223     # the process, so we need to put PERL5LIB back.
224     my $previous = $ENV{PERL5LIB};
225     my $teardown = sub {
226         if ( defined $previous ) {
227             $ENV{PERL5LIB} = $previous;
228         }
229         else {
230             delete $ENV{PERL5LIB};
231         }
232     };
233
234     return ( $setup, $teardown );
235 }
236
237 sub _run {
238     my ( $class, $source, $libs, $switches ) = @_;
239
240     my @command = $class->_get_command_for_switches( $source, $switches )
241       or $class->_croak("No command found!");
242
243     my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches );
244
245     return $class->_create_iterator( $source, \@command, $setup, $teardown );
246 }
247
248 sub _create_iterator {
249     my ( $class, $source, $command, $setup, $teardown ) = @_;
250
251     return TAP::Parser::Iterator::Process->new(
252         {   command  => $command,
253             merge    => $source->merge,
254             setup    => $setup,
255             teardown => $teardown,
256         }
257     );
258 }
259
260 sub _get_command_for_switches {
261     my ( $class, $source, $switches ) = @_;
262     my $file    = ${ $source->raw };
263     my @args    = @{ $source->test_args || [] };
264     my $command = $class->get_perl;
265
266    # XXX don't need to quote if we treat the parts as atoms (except maybe vms)
267    #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
268     my @command = ( $command, @{$switches}, $file, @args );
269     return @command;
270 }
271
272 sub _libs2switches {
273     my $class = shift;
274     return map {"-I$_"} grep {$_} @{ $_[0] };
275 }
276
277 =head3 C<get_taint>
278
279 Decode any taint switches from a Perl shebang line.
280
281   # $taint will be 't'
282   my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' );
283
284   # $untaint will be undefined
285   my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' );
286
287 =cut
288
289 sub get_taint {
290     my ( $class, $shebang ) = @_;
291     return
292       unless defined $shebang
293           && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
294     return $1;
295 }
296
297 sub _switches {
298     my ( $class, $source ) = @_;
299     my $file     = ${ $source->raw };
300     my @switches = @{ $source->switches || [] };
301     my $shebang  = $source->meta->{file}->{shebang};
302     return unless defined $shebang;
303
304     my $taint = $class->get_taint($shebang);
305     push @switches, "-$taint" if defined $taint;
306
307     # Quote the argument if we're VMS, since VMS will downcase anything
308     # not quoted.
309     if (IS_VMS) {
310         for (@switches) {
311             $_ = qq["$_"];
312         }
313     }
314
315     return @switches;
316 }
317
318 =head3 C<get_perl>
319
320 Gets the version of Perl currently running the test suite.
321
322 =cut
323
324 sub get_perl {
325     my $class = shift;
326     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
327     return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ );
328     return $^X;
329 }
330
331 1;
332
333 __END__
334
335 =head1 SUBCLASSING
336
337 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
338
339 =head2 Example
340
341   package MyPerlSourceHandler;
342
343   use strict;
344
345   use TAP::Parser::SourceHandler::Perl;
346
347   use base 'TAP::Parser::SourceHandler::Perl';
348
349   # use the version of perl from the shebang line in the test file
350   sub get_perl {
351       my $self = shift;
352       if (my $shebang = $self->shebang( $self->{file} )) {
353           $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
354           return $1 if $1;
355       }
356       return $self->SUPER::get_perl(@_);
357   }
358
359 =head1 SEE ALSO
360
361 L<TAP::Object>,
362 L<TAP::Parser>,
363 L<TAP::Parser::IteratorFactory>,
364 L<TAP::Parser::SourceHandler>,
365 L<TAP::Parser::SourceHandler::Executable>,
366 L<TAP::Parser::SourceHandler::File>,
367 L<TAP::Parser::SourceHandler::Handle>,
368 L<TAP::Parser::SourceHandler::RawTAP>
369
370 =cut