diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm | 326 |
1 files changed, 0 insertions, 326 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm deleted file mode 100644 index 1f4f2e1428c..00000000000 --- a/Master/tlpkg/tlperl/lib/TAP/Parser/Source/Perl.pm +++ /dev/null @@ -1,326 +0,0 @@ -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 |