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 Takes a filename and hopefully returns a stream from it. The filename should
28 be the name of a Perl program.
30 Note that this is a subclass of L<TAP::Parser::Source>. See that module for
35 use TAP::Parser::Source::Perl;
36 my $perl = TAP::Parser::Source::Perl->new;
37 my $stream = $perl->source( [ $filename, @args ] )->get_stream;
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 ] );
62 $self->_croak("Cannot find ($_[0][0])")
63 if @_ && !-f $_[0][0];
64 return $self->SUPER::source(@_);
69 my $switches = $perl->switches;
70 my @switches = $perl->switches;
71 $perl->switches( \@switches );
73 Getter/setter for the additional switches to pass to the perl executable. One
74 common switch would be to set an include directory:
76 $perl->switches( ['-Ilib'] );
83 return wantarray ? @{ $self->{switches} } : $self->{switches};
86 $self->{switches} = [@$switches]; # force a copy
90 ##############################################################################
94 my $stream = $source->get_stream;
96 Returns a stream of the output generated by executing C<source>.
105 my @switches = $self->_switches;
106 my $path_sep = $Config{path_sep};
107 my $path_pat = qr{$path_sep};
109 # Nasty kludge. It might be nicer if we got the libs separately
110 # although at least this way we find any -I switches that were
111 # supplied other then as explicit libs.
112 # We filter out any names containing colons because they will break
115 for ( grep { $_ !~ $path_pat } @switches ) {
116 push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
119 my $previous = $ENV{PERL5LIB};
121 push @libs, split( $path_pat, $previous );
126 $ENV{PERL5LIB} = join( $path_sep, @libs );
130 # Cargo culted from comments seen elsewhere about VMS / environment
131 # variables. I don't know if this is actually necessary.
134 $ENV{PERL5LIB} = $previous;
137 delete $ENV{PERL5LIB};
141 # Taint mode ignores environment variables so we must retranslate
142 # PERL5LIB as -I switches and place PERL5OPT on the command line
143 # in order that it be seen.
144 if ( grep { $_ eq "-T" } @switches ) {
146 $self->_libs2switches(
148 $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
151 push @switches, $ENV{PERL5OPT} || ();
154 my @command = $self->_get_command_for_switches(@switches)
155 or $self->_croak("No command found!");
157 return TAP::Parser::Iterator->new(
158 { command => \@command,
159 merge => $self->merge,
161 teardown => $teardown,
166 sub _get_command_for_switches {
169 my ( $file, @args ) = @{ $self->source };
170 my $command = $self->_get_perl;
172 $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
173 my @command = ( $command, @switches, $file, @args );
179 return $self->_get_command_for_switches( $self->_switches );
184 return map {"-I$_"} grep {$_} @_;
189 Get the shebang line for a script file.
191 my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
193 May be called as a class method
199 # Global shebang cache.
206 if ( open( TEST, $file ) ) {
208 close(TEST) or print "Can't close $file. $!\n";
211 print "Can't open $file. $!\n";
217 my ( $class, $file ) = @_;
218 unless ( exists $shebang_for{$file} ) {
219 $shebang_for{$file} = _read_shebang($file);
221 return $shebang_for{$file};
227 Decode any taint switches from a Perl shebang line.
230 my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
232 # $untaint will be undefined
233 my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
238 my ( $class, $shebang ) = @_;
240 unless defined $shebang
241 && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
247 my ( $file, @args ) = @{ $self->source };
252 my $shebang = $self->shebang($file);
253 return unless defined $shebang;
255 my $taint = $self->get_taint($shebang);
256 push @switches, "-$taint" if defined $taint;
258 # Quote the argument if there's any whitespace in it, or if
259 # we're VMS, since VMS requires all parms quoted. Also, don't quote
260 # it if it's already quoted.
262 $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
265 my %found_switch = map { $_ => 0 } @switches;
267 # remove duplicate switches
269 = grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
275 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
276 return Win32::GetShortPathName($^X) if IS_WIN32;