1 package TAP::Parser::Source::Perl;
5 use vars qw($VERSION @ISA);
7 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
8 use constant IS_VMS => ( $^O eq 'VMS' );
10 use TAP::Parser::Source;
11 use TAP::Parser::Utils qw( split_shell );
13 @ISA = 'TAP::Parser::Source';
17 TAP::Parser::Source::Perl - Stream Perl output
29 use TAP::Parser::Source::Perl;
30 my $perl = TAP::Parser::Source::Perl->new;
31 my $stream = $perl->source( [ $filename, @args ] )->get_stream;
35 Takes a filename and hopefully returns a stream from it. The filename should
36 be the name of a Perl program.
38 Note that this is a subclass of L<TAP::Parser::Source>. See that module for
47 my $perl = TAP::Parser::Source::Perl->new;
49 Returns a new C<TAP::Parser::Source::Perl> object.
51 =head2 Instance Methods
55 Getter/setter the name of the test program and any arguments it requires.
57 my ($filename, @args) = @{ $perl->source };
58 $perl->source( [ $filename, @args ] );
60 C<croak>s if C<$filename> could not be found.
66 $self->_croak("Cannot find ($_[0][0])")
67 if @_ && !-f $_[0][0];
68 return $self->SUPER::source(@_);
73 my $switches = $perl->switches;
74 my @switches = $perl->switches;
75 $perl->switches( \@switches );
77 Getter/setter for the additional switches to pass to the perl executable. One
78 common switch would be to set an include directory:
80 $perl->switches( ['-Ilib'] );
87 return wantarray ? @{ $self->{switches} } : $self->{switches};
90 $self->{switches} = [@$switches]; # force a copy
94 ##############################################################################
98 my $stream = $source->get_stream($parser);
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.
107 my ( $self, $factory ) = @_;
109 my @switches = $self->_switches;
110 my $path_sep = $Config{path_sep};
111 my $path_pat = qr{$path_sep};
113 # Filter out any -I switches to be handled as libs later.
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.
119 # We filter out any names containing colons because they will break
122 my @filtered_switches;
124 if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
128 push @filtered_switches, $_;
131 @switches = @filtered_switches;
136 = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
140 # Cargo culted from comments seen elsewhere about VMS / environment
141 # variables. I don't know if this is actually necessary.
142 my $previous = $ENV{PERL5LIB};
144 if ( defined $previous ) {
145 $ENV{PERL5LIB} = $previous;
148 delete $ENV{PERL5LIB};
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.
155 if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
156 push @switches, $self->_libs2switches(@libs);
157 push @switches, split_shell( $ENV{PERL5OPT} );
160 my @command = $self->_get_command_for_switches(@switches)
161 or $self->_croak("No command found!");
163 return $factory->make_iterator(
164 { command => \@command,
165 merge => $self->merge,
167 teardown => $teardown,
172 sub _get_command_for_switches {
175 my ( $file, @args ) = @{ $self->source };
176 my $command = $self->_get_perl;
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 !~ /^".*"$/ );
180 my @command = ( $command, @switches, $file, @args );
186 return $self->_get_command_for_switches( $self->_switches );
191 return map {"-I$_"} grep {$_} @_;
196 Get the shebang line for a script file.
198 my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
200 May be called as a class method
206 # Global shebang cache.
213 if ( open( TEST, $file ) ) {
215 close(TEST) or print "Can't close $file. $!\n";
218 print "Can't open $file. $!\n";
224 my ( $class, $file ) = @_;
225 unless ( exists $shebang_for{$file} ) {
226 $shebang_for{$file} = _read_shebang($file);
228 return $shebang_for{$file};
234 Decode any taint switches from a Perl shebang line.
237 my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
239 # $untaint will be undefined
240 my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
245 my ( $class, $shebang ) = @_;
247 unless defined $shebang
248 && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
254 my ( $file, @args ) = @{ $self->source };
259 my $shebang = $self->shebang($file);
260 return unless defined $shebang;
262 my $taint = $self->get_taint($shebang);
263 push @switches, "-$taint" if defined $taint;
265 # Quote the argument if we're VMS, since VMS will downcase anything
278 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
279 return Win32::GetShortPathName($^X) if IS_WIN32;
287 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
291 package MyPerlSource;
296 use Carp qw( croak );
297 use TAP::Parser::Source::Perl;
299 @ISA = qw( TAP::Parser::Source::Perl );
302 my ($self, $args) = @_;
304 $self->{file} = $args->[0];
305 return $self->SUPER::source($args);
307 return $self->SUPER::source;
310 # use the version of perl from the shebang line in the test file
313 if (my $shebang = $self->shebang( $self->{file} )) {
314 $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
317 return $self->SUPER::_get_perl(@_);
324 L<TAP::Parser::Source>,