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