package TAP::Parser::Source::Perl;
use strict;
use vars qw($VERSION @ISA);
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_MACOS => ( $^O eq 'MacOS' );
use constant IS_VMS => ( $^O eq 'VMS' );
use TAP::Parser::Source;
@ISA = 'TAP::Parser::Source';
=head1 NAME
TAP::Parser::Source::Perl - Stream Perl output
=head1 VERSION
Version 2.99_01
=cut
$VERSION = '2.99_01';
=head1 DESCRIPTION
Takes a filename and hopefully returns a stream from it. The filename should
be the name of a Perl program.
Note that this is a subclass of L<TAP::Parser::Source>. See that module for
more methods.
=head1 SYNOPSIS
use TAP::Parser::Source::Perl;
my $perl = TAP::Parser::Source::Perl->new;
my $stream = $perl->source_file($filename)->get_stream;
=head1 METHODS
=head2 Class Methods
=head3 C<new>
my $perl = TAP::Parser::Source::Perl->new;
Returns a new C<TAP::Parser::Source::Perl> object.
=head2 Instance Methods
=head3 C<source_file>
my $perl = $source->source;
$perl->source_file($filename);
Getter/setter for the source filename. Will C<croak> if the C<$filename> does
not appear to be a file.
=cut
sub source_file {
my $self = shift;
return $self->{source_file} unless @_;
my $filename = shift;
unless ( -f $filename ) {
$self->_croak("Cannot find ($filename)");
}
$self->{source_file} = $filename;
return $self;
}
=head3 C<switches>
my $switches = $perl->switches;
my @switches = $perl->switches;
$perl->switches(\@switches);
Getter/setter for the additional switches to pass to the perl executable. One
common switch would be to set an include directory:
$perl->switches('-Ilib');
=cut
sub switches {
my $self = shift;
unless (@_) {
return wantarray ? @{ $self->{switches} } : $self->{switches};
}
my $switches = shift;
$self->{switches} = [@$switches]; # force a copy
return $self;
}
##############################################################################
=head3 C<get_stream>
my $stream = $source->get_stream;
Returns a stream of the output generated by executing C<source_file>.
=cut
sub get_stream {
my $self = shift;
my @switches = $self->_switches;
my @command = $self->_get_command_for_switches(@switches)
or $self->_croak("No command found!");
# Nasty kludge. It might be nicer if we got the libs separately
# although at least this way we find any -I switches that were
# supplied other then as explicit libs.
# We filter out any names containing colons because they will break
# PERL5LIB
my @libs;
for ( grep { $_ !~ /:/ } @switches ) {
push @libs, $1 if / ^ -I (.*) $ /x;
}
my $previous = $ENV{PERL5LIB};
if ($previous) {
push @libs, split( /:/, $previous );
}
my $setup = sub {
if (@libs) {
$ENV{PERL5LIB} = join( ':', @libs );
}
};
# Cargo culted from comments seen elsewhere about VMS / environment
# variables. I don't know if this is actually necessary.
my $teardown = sub {
if ($previous) {
$ENV{PERL5LIB} = $previous;
}
else {
delete $ENV{PERL5LIB};
}
};
return TAP::Parser::Iterator->new(
{ command => \@command,
merge => $self->merge,
setup => $setup,
teardown => $teardown,
}
);
}
sub _get_command_for_switches {
my $self = shift;
my @switches = @_;
my $file = $self->source_file;
my $command = $self->_get_perl;
$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
my @command = ( $command, @switches, $file );
return @command;
}
sub _get_command {
my $self = shift;
return $self->_get_command_for_switches( $self->_switches );
}
sub _switches {
my $self = shift;
my $file = $self->source_file;
my @switches = (
$self->switches,
);
local *TEST;
open( TEST, $file ) or print "can't open $file. $!\n";
my $shebang = <TEST>;
close(TEST) or print "can't close $file. $!\n";
$self->_croak("Script $file is empty") unless defined $shebang;
my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
push( @switches, "-$1" ) if $taint;
push @switches, map {"-I$_"} $self->_filtered_inc;
# Quote the argument if there's any whitespace in it, or if
# we're VMS, since VMS requires all parms quoted. Also, don't quote
# it if it's already quoted.
for (@switches) {
$_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
}
my %found_switch = map { $_ => 0 } @switches;
# remove duplicate switches
@switches
= grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
return @switches;
}
sub _filtered_inc {
my $self = shift;
my @inc = @_;
@inc = @INC unless @inc;
if (IS_VMS) {
# VMS has a 255-byte limit on the length of %ENV entries, so
# toss the ones that involve perl_root, the install location
@inc = grep !/perl_root/i, @inc;
}
elsif (IS_WIN32) {
# Lose any trailing backslashes in the Win32 paths
s/[\\\/+]$// foreach @inc;
}
my %seen;
$seen{$_}++ foreach $self->_default_inc;
@inc = grep !$seen{$_}++, @inc;
return @inc;
}
{
# cache this to avoid repeatedly shelling out to Perl. This really speeds
# up TAP::Parser.
my @inc;
sub _default_inc {
return @inc if @inc;
my $proto = shift;
local $ENV{PERL5LIB};
local $ENV{PERLLIB}; # [12030] fix untested
my $perl = $proto->_get_perl;
chomp( @inc = `$perl -le "print join qq[\\n], \@INC"` );
return @inc;
}
}
sub _get_perl {
my $proto = shift;
return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
return Win32::GetShortPathName($^X) if IS_WIN32;
return $^X;
}
1;