bring Test::Harness up to 3.06

[p5sagit/p5-mst-13.2.git] / lib / TAP / Parser / Source / Perl.pm

package TAP::Parser::Source::Perl;

use strict;
use Config;
use vars qw($VERSION @ISA);

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
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 3.06

=cut

$VERSION = '3.06';

=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( [ $filename, @args ] )->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>

Getter/setter the name of the test program and any arguments it requires.

  my ($filename, @args) = @{ $perl->source };
  $perl->source( [ $filename, @args ] );

=cut

sub source {
    my $self = shift;
    $self->_croak("Cannot find ($_[0][0])")
      if @_ && !-f $_[0][0];
    return $self->SUPER::source(@_);
}

=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>.

=cut

sub get_stream {
    my $self = shift;

    my @extra_libs;

    my @switches = $self->_switches;
    my $path_sep = $Config{path_sep};
    my $path_pat = qr{$path_sep};

    # 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 { $_ !~ $path_pat } @switches ) {
        push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
    }

    my $previous = $ENV{PERL5LIB};
    if ($previous) {
        push @libs, split( $path_pat, $previous );
    }

    my $setup = sub {
        if (@libs) {
            $ENV{PERL5LIB} = join( $path_sep, @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};
        }
    };

    # Taint mode ignores environment variables so we must retranslate
    # PERL5LIB as -I switches and place PERL5OPT on the command line
    # in order that it be seen.
    if ( grep { $_ eq "-T" } @switches ) {
        push @switches,
          $self->_libs2switches(
            split $path_pat,
            $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
          );

        push @switches, $ENV{PERL5OPT} || ();
    }

    my @command = $self->_get_command_for_switches(@switches)
      or $self->_croak("No command found!");

    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, @args ) = @{ $self->source };
    my $command = $self->_get_perl;

    $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
    my @command = ( $command, @switches, $file, @args );
    return @command;
}

sub _get_command {
    my $self = shift;
    return $self->_get_command_for_switches( $self->_switches );
}

sub _libs2switches {
    my $self = shift;
    return map {"-I$_"} grep {$_} @_;
}

=head3 C<shebang>

Get the shebang line for a script file.

    my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );

May be called as a class method

=cut

{

    # Global shebang cache.
    my %shebang_for;

    sub _read_shebang {
        my $file = shift;
        local *TEST;
        my $shebang;
        if ( open( TEST, $file ) ) {
            $shebang = <TEST>;
            close(TEST) or print "Can't close $file. $!\n";
        }
        else {
            print "Can't open $file. $!\n";
        }
        return $shebang;
    }

    sub shebang {
        my ( $class, $file ) = @_;
        unless ( exists $shebang_for{$file} ) {
            $shebang_for{$file} = _read_shebang($file);
        }
        return $shebang_for{$file};
    }
}

=head3 C<get_taint>

Decode any taint switches from a Perl shebang line.

    # $taint will be 't'
    my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );

    # $untaint will be undefined
    my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );    

=cut

sub get_taint {
    my ( $class, $shebang ) = @_;
    return
      unless defined $shebang
          && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
    return $1;
}

sub _switches {
    my $self = shift;
    my ( $file, @args ) = @{ $self->source };
    my @switches = (
        $self->switches,
    );

    my $shebang = $self->shebang($file);
    return unless defined $shebang;

    my $taint = $self->get_taint($shebang);
    push @switches, "-$taint" if defined $taint;

    # 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 _get_perl {
    my $proto = shift;
    return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
    return Win32::GetShortPathName($^X) if IS_WIN32;
    return $^X;
}

1;