1 files changed, 326 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm
new file mode 100755
index 00000000000..1f4f2e1428c
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm
@@ -0,0 +1,326 @@
+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;
+use TAP::Parser::Utils qw( split_shell );
+
+@ISA = 'TAP::Parser::Source';
+
+=head1 NAME
+
+TAP::Parser::Source::Perl - Stream Perl output
+
+=head1 VERSION
+
+Version 3.17
+
+=cut
+
+$VERSION = '3.17';
+
+=head1 SYNOPSIS
+
+  use TAP::Parser::Source::Perl;
+  my $perl = TAP::Parser::Source::Perl->new;
+  my $stream = $perl->source( [ $filename, @args ] )->get_stream;
+
+=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 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 ] );
+
+C<croak>s if C<$filename> could not be found.
+
+=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($parser);
+
+Returns a stream of the output generated by executing C<source>. Must be
+passed an object that implements a C<make_iterator> method. Typically
+this is a TAP::Parser instance.
+
+=cut
+
+sub get_stream {
+    my ( $self, $factory ) = @_;
+
+    my @switches = $self->_switches;
+    my $path_sep = $Config{path_sep};
+    my $path_pat = qr{$path_sep};
+
+    # Filter out any -I switches to be handled as libs later.
+    #
+    # 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;
+    my @filtered_switches;
+    for (@switches) {
+        if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
+            push @libs, $1;
+        }
+        else {
+            push @filtered_switches, $_;
+        }
+    }
+    @switches = @filtered_switches;
+
+    my $setup = sub {
+        if (@libs) {
+            $ENV{PERL5LIB}
+              = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
+        }
+    };
+
+    # Cargo culted from comments seen elsewhere about VMS / environment
+    # variables. I don't know if this is actually necessary.
+    my $previous = $ENV{PERL5LIB};
+    my $teardown = sub {
+        if ( defined $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" || $_ eq "-t" } @switches ) {
+        push @switches, $self->_libs2switches(@libs);
+        push @switches, split_shell( $ENV{PERL5OPT} );
+    }
+
+    my @command = $self->_get_command_for_switches(@switches)
+      or $self->_croak("No command found!");
+
+    return $factory->make_iterator(
+        {   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;
+
+# XXX we never need to quote if we treat the parts as atoms (except maybe vms)
+#$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 we're VMS, since VMS will downcase anything
+    # not quoted.
+    if (IS_VMS) {
+        for (@switches) {
+            $_ = qq["$_"];
+        }
+    }
+
+    return @switches;
+}
+
+sub _get_perl {
+    my $self = shift;
+    return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
+    return Win32::GetShortPathName($^X) if IS_WIN32;
+    return $^X;
+}
+
+1;
+
+=head1 SUBCLASSING
+
+Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
+
+=head2 Example
+
+  package MyPerlSource;
+
+  use strict;
+  use vars '@ISA';
+
+  use Carp qw( croak );
+  use TAP::Parser::Source::Perl;
+
+  @ISA = qw( TAP::Parser::Source::Perl );
+
+  sub source {
+      my ($self, $args) = @_;
+      if ($args) {
+	  $self->{file} = $args->[0];
+	  return $self->SUPER::source($args);
+      }
+      return $self->SUPER::source;
+  }
+
+  # use the version of perl from the shebang line in the test file
+  sub _get_perl {
+      my $self = shift;
+      if (my $shebang = $self->shebang( $self->{file} )) {
+          $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
+	  return $1 if $1;
+      }
+      return $self->SUPER::_get_perl(@_);
+  }
+
+=head1 SEE ALSO
+
+L<TAP::Object>,
+L<TAP::Parser>,
+L<TAP::Parser::Source>,
+
+=cut