package TAPx::Parser::Source::Perl;

use strict;
use warnings;
use vars qw($VERSION);
use Symbol 'gensym';

use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
use constant IS_MACOS => ( $^O eq 'MacOS' );
use constant IS_VMS   => ( $^O eq 'VMS' );

use TAPx::Parser::Iterator;

=head1 NAME

TAPx::Parser::Source::Perl - Stream Perl output

=head1 VERSION

Version 0.20

=cut

$VERSION = '0.20';

=head1 DESCRIPTION

Takes a filename and hopefully returns a stream from it.  The filename should
be the name of a Perl program.

=head1 SYNOPSIS

 use TAPx::Parser::Source::Perl;
 my $source = TAPx::Parser::Source::Perl->new;
 my $stream = $source->filename($filename)->get_stream;

##############################################################################

=head1 METHODS

=head2 Class methods

=head3 C<new>

 my $source = TAPx::Parser::Source::Perl->new;

Returns a new C<TAPx::Parser::Source::Perl> object.

=cut

sub new {
    my $class = shift;
    _autoflush( \*STDOUT );
    _autoflush( \*STDERR );
    bless {}, $class;
}

##############################################################################

=head2 Instace methods

=head3 C<filename>

 my $filename = $source->filename;
 $source->filename($filename);

Getter/setter for the source filename.  Will C<croak> if the C<$filename> does
not appear to be a file.

=cut

sub filename {
    my $self = shift;
    return $self->{filename} unless @_;
    my $filename = shift;
    unless ( -f $filename ) {
        $self->_croak("Cannot find ($filename)");
    }
    $self->{filename} = $filename;
    return $self;
}

##############################################################################

=head3 C<get_stream>

 my $stream = $source->get_stream;

Returns a stream of the output generated by executing C<filename>.

=cut

sub get_stream {
    my ( $self ) = @_;
    my $command = $self->_get_command;

    # note that you cannot localize the filehandle because, if you do,
    # as soon as it goes out of scope, the iterator can no longer read from
    # it.  You'll get "Can't dup STDOUT:  bad file descriptor" errors.
    # Thus, we use a filehandle that's unlikely to be reused.

    # -| is safer, but not portable.
    # redirecting STDERR to STDOUT seems to keep them in sync
    # but I lose a bit of formatting for some reason
    my $sym = gensym;
    if ( open $sym, "$command 2>&1 |" ) {
        return TAPx::Parser::Iterator->new($sym);
    }
    else {
        $self->error("Could not execute ($command): $!");
        return;
    }
}

##############################################################################

=head3 C<error>

 unless ( my $stream = $source->get_stream ) {
     die $source->error;
 }

If a stream cannot be created, this method will return the error.

=cut

sub error {
    my $self = shift;
    return $self->{error} unless @_;
    $self->{error} = shift;
    return $self;
}

# Turns on autoflush for the handle passed
sub _autoflush {
    my $flushed = shift;
    my $old_fh  = select $flushed;
    $| = 1;
    select $old_fh;
}

sub _get_command {
    my $self = shift;
    my $file = $self->filename;
    my $command  = $self->_get_perl;
    my $switches = $self->_switches;

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

sub _switches {
    my $self = shift;
    my $file = $self->filename;
    my @derivedswitches;

    local *TEST;
    open( TEST, $file ) or print "can't open $file. $!\n";
    my $shebang = <TEST>;
    close(TEST) or print "can't close $file. $!\n";

    my $taint = ( $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ );
    push( @derivedswitches, "-$1" ) if $taint;

    # When taint mode is on, PERL5LIB is ignored.  So we need to put
    # all that on the command line as -Is.
    # MacPerl's putenv is broken, so it will not see PERL5LIB, tainted or not.
    if ( $taint || IS_MACOS ) {
        my @inc = $self->_filtered_inc;
        push @derivedswitches, map {"-I$_"} @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 (@derivedswitches) {
        $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
    }
    return join( " ", @derivedswitches );
}

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;
}

sub _default_inc {
    my $proto = shift;
    local $ENV{PERL5LIB};
    my $perl = $proto->_get_perl;
    my @inc  = `$perl -le "print join qq[\\n], \@INC"`;
    chomp @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;
}

sub _croak {
    my $self = shift;
    require Carp;
    Carp::croak(@_);
}

1;
