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 @ISA = 'TAP::Parser::Source';
15 TAP::Parser::Source::Perl - Stream Perl output
27 use TAP::Parser::Source::Perl;
28 my $perl = TAP::Parser::Source::Perl->new;
29 my $stream = $perl->source( [ $filename, @args ] )->get_stream;
33 Takes a filename and hopefully returns a stream from it. The filename should
34 be the name of a Perl program.
36 Note that this is a subclass of L<TAP::Parser::Source>. See that module for
45 my $perl = TAP::Parser::Source::Perl->new;
47 Returns a new C<TAP::Parser::Source::Perl> object.
49 =head2 Instance Methods
53 Getter/setter the name of the test program and any arguments it requires.
55 my ($filename, @args) = @{ $perl->source };
56 $perl->source( [ $filename, @args ] );
58 C<croak>s if C<$filename> could not be found.
64 $self->_croak("Cannot find ($_[0][0])")
65 if @_ && !-f $_[0][0];
66 return $self->SUPER::source(@_);
71 my $switches = $perl->switches;
72 my @switches = $perl->switches;
73 $perl->switches( \@switches );
75 Getter/setter for the additional switches to pass to the perl executable. One
76 common switch would be to set an include directory:
78 $perl->switches( ['-Ilib'] );
85 return wantarray ? @{ $self->{switches} } : $self->{switches};
88 $self->{switches} = [@$switches]; # force a copy
92 ##############################################################################
96 my $stream = $source->get_stream($parser);
98 Returns a stream of the output generated by executing C<source>. Must be
99 passed an object that implements a C<make_iterator> method. Typically
100 this is a TAP::Parser instance.
105 my ( $self, $factory ) = @_;
109 my @switches = $self->_switches;
110 my $path_sep = $Config{path_sep};
111 my $path_pat = qr{$path_sep};
113 # Nasty kludge. It might be nicer if we got the libs separately
114 # although at least this way we find any -I switches that were
115 # supplied other then as explicit libs.
116 # We filter out any names containing colons because they will break
119 for ( grep { $_ !~ $path_pat } @switches ) {
120 push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
123 my $previous = $ENV{PERL5LIB};
125 push @libs, split( $path_pat, $previous );
130 $ENV{PERL5LIB} = join( $path_sep, @libs );
134 # Cargo culted from comments seen elsewhere about VMS / environment
135 # variables. I don't know if this is actually necessary.
138 $ENV{PERL5LIB} = $previous;
141 delete $ENV{PERL5LIB};
145 # Taint mode ignores environment variables so we must retranslate
146 # PERL5LIB as -I switches and place PERL5OPT on the command line
147 # in order that it be seen.
148 if ( grep { $_ eq "-T" } @switches ) {
150 $self->_libs2switches(
152 $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
155 push @switches, $ENV{PERL5OPT} || ();
158 my @command = $self->_get_command_for_switches(@switches)
159 or $self->_croak("No command found!");
161 return $factory->make_iterator(
162 { command => \@command,
163 merge => $self->merge,
165 teardown => $teardown,
170 sub _get_command_for_switches {
173 my ( $file, @args ) = @{ $self->source };
174 my $command = $self->_get_perl;
176 # XXX we never need to quote if we treat the parts as atoms (except maybe vms)
177 #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
178 my @command = ( $command, @switches, $file, @args );
184 return $self->_get_command_for_switches( $self->_switches );
189 return map {"-I$_"} grep {$_} @_;
194 Get the shebang line for a script file.
196 my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
198 May be called as a class method
204 # Global shebang cache.
211 if ( open( TEST, $file ) ) {
213 close(TEST) or print "Can't close $file. $!\n";
216 print "Can't open $file. $!\n";
222 my ( $class, $file ) = @_;
223 unless ( exists $shebang_for{$file} ) {
224 $shebang_for{$file} = _read_shebang($file);
226 return $shebang_for{$file};
232 Decode any taint switches from a Perl shebang line.
235 my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
237 # $untaint will be undefined
238 my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
243 my ( $class, $shebang ) = @_;
245 unless defined $shebang
246 && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
252 my ( $file, @args ) = @{ $self->source };
257 my $shebang = $self->shebang($file);
258 return unless defined $shebang;
260 my $taint = $self->get_taint($shebang);
261 push @switches, "-$taint" if defined $taint;
263 # Quote the argument if there's any whitespace in it, or if
264 # we're VMS, since VMS requires all parms quoted. Also, don't quote
265 # it if it's already quoted.
267 $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
275 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
276 return Win32::GetShortPathName($^X) if IS_WIN32;
284 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
288 package MyPerlSource;
293 use Carp qw( croak );
294 use TAP::Parser::Source::Perl;
296 @ISA = qw( TAP::Parser::Source::Perl );
299 my ($self, $args) = @_;
301 $self->{file} = $args->[0];
302 return $self->SUPER::source($args);
304 return $self->SUPER::source;
307 # use the version of perl from the shebang line in the test file
310 if (my $shebang = $self->shebang( $self->{file} )) {
311 $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
314 return $self->SUPER::_get_perl(@_);
321 L<TAP::Parser::Source>,