ext/Test-Harness/lib/TAP/Parser/Source/Perl.pm

   1 package TAP::Parser::Source::Perl;
   2
   3 use strict;
   4 use Config;
   5 use vars qw($VERSION @ISA);
   6
   7 use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
   8 use constant IS_VMS => ( $^O eq 'VMS' );
   9
  10 use TAP::Parser::Source;
  11 use TAP::Parser::Utils qw( split_shell );
  12
  13 @ISA = 'TAP::Parser::Source';
  14
  15 =head1 NAME
  16
  17 TAP::Parser::Source::Perl - Stream Perl output
  18
  19 =head1 VERSION
  20
  21 Version 3.17
  22
  23 =cut
  24
  25 $VERSION = '3.17';
  26
  27 =head1 SYNOPSIS
  28
  29   use TAP::Parser::Source::Perl;
  30   my $perl = TAP::Parser::Source::Perl->new;
  31   my $stream = $perl->source( [ $filename, @args ] )->get_stream;
  32
  33 =head1 DESCRIPTION
  34
  35 Takes a filename and hopefully returns a stream from it.  The filename should
  36 be the name of a Perl program.
  37
  38 Note that this is a subclass of L<TAP::Parser::Source>.  See that module for
  39 more methods.
  40
  41 =head1 METHODS
  42
  43 =head2 Class Methods
  44
  45 =head3 C<new>
  46
  47  my $perl = TAP::Parser::Source::Perl->new;
  48
  49 Returns a new C<TAP::Parser::Source::Perl> object.
  50
  51 =head2 Instance Methods
  52
  53 =head3 C<source>
  54
  55 Getter/setter the name of the test program and any arguments it requires.
  56
  57   my ($filename, @args) = @{ $perl->source };
  58   $perl->source( [ $filename, @args ] );
  59
  60 C<croak>s if C<$filename> could not be found.
  61
  62 =cut
  63
  64 sub source {
  65     my $self = shift;
  66     $self->_croak("Cannot find ($_[0][0])")
  67       if @_ && !-f $_[0][0];
  68     return $self->SUPER::source(@_);
  69 }
  70
  71 =head3 C<switches>
  72
  73   my $switches = $perl->switches;
  74   my @switches = $perl->switches;
  75   $perl->switches( \@switches );
  76
  77 Getter/setter for the additional switches to pass to the perl executable.  One
  78 common switch would be to set an include directory:
  79
  80   $perl->switches( ['-Ilib'] );
  81
  82 =cut
  83
  84 sub switches {
  85     my $self = shift;
  86     unless (@_) {
  87         return wantarray ? @{ $self->{switches} } : $self->{switches};
  88     }
  89     my $switches = shift;
  90     $self->{switches} = [@$switches];    # force a copy
  91     return $self;
  92 }
  93
  94 ##############################################################################
  95
  96 =head3 C<get_stream>
  97
  98   my $stream = $source->get_stream($parser);
  99
 100 Returns a stream of the output generated by executing C<source>. Must be
 101 passed an object that implements a C<make_iterator> method. Typically
 102 this is a TAP::Parser instance.
 103
 104 =cut
 105
 106 sub get_stream {
 107     my ( $self, $factory ) = @_;
 108
 109     my @switches = $self->_switches;
 110     my $path_sep = $Config{path_sep};
 111     my $path_pat = qr{$path_sep};
 112
 113     # Filter out any -I switches to be handled as libs later.
 114     #
 115     # Nasty kludge. It might be nicer if we got the libs separately
 116     # although at least this way we find any -I switches that were
 117     # supplied other then as explicit libs.
 118     #
 119     # We filter out any names containing colons because they will break
 120     # PERL5LIB
 121     my @libs;
 122     my @filtered_switches;
 123     for (@switches) {
 124         if ( !/$path_pat/ && / ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) {
 125             push @libs, $1;
 126         }
 127         else {
 128             push @filtered_switches, $_;
 129         }
 130     }
 131     @switches = @filtered_switches;
 132
 133     my $setup = sub {
 134         if (@libs) {
 135             $ENV{PERL5LIB}
 136               = join( $path_sep, grep {defined} @libs, $ENV{PERL5LIB} );
 137         }
 138     };
 139
 140     # Cargo culted from comments seen elsewhere about VMS / environment
 141     # variables. I don't know if this is actually necessary.
 142     my $previous = $ENV{PERL5LIB};
 143     my $teardown = sub {
 144         if ( defined $previous ) {
 145             $ENV{PERL5LIB} = $previous;
 146         }
 147         else {
 148             delete $ENV{PERL5LIB};
 149         }
 150     };
 151
 152     # Taint mode ignores environment variables so we must retranslate
 153     # PERL5LIB as -I switches and place PERL5OPT on the command line
 154     # in order that it be seen.
 155     if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
 156         push @switches, $self->_libs2switches(@libs);
 157         push @switches, split_shell( $ENV{PERL5OPT} );
 158     }
 159
 160     my @command = $self->_get_command_for_switches(@switches)
 161       or $self->_croak("No command found!");
 162
 163     return $factory->make_iterator(
 164         {   command  => \@command,
 165             merge    => $self->merge,
 166             setup    => $setup,
 167             teardown => $teardown,
 168         }
 169     );
 170 }
 171
 172 sub _get_command_for_switches {
 173     my $self     = shift;
 174     my @switches = @_;
 175     my ( $file, @args ) = @{ $self->source };
 176     my $command = $self->_get_perl;
 177
 178 # XXX we never need to quote if we treat the parts as atoms (except maybe vms)
 179 #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
 180     my @command = ( $command, @switches, $file, @args );
 181     return @command;
 182 }
 183
 184 sub _get_command {
 185     my $self = shift;
 186     return $self->_get_command_for_switches( $self->_switches );
 187 }
 188
 189 sub _libs2switches {
 190     my $self = shift;
 191     return map {"-I$_"} grep {$_} @_;
 192 }
 193
 194 =head3 C<shebang>
 195
 196 Get the shebang line for a script file.
 197
 198   my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
 199
 200 May be called as a class method
 201
 202 =cut
 203
 204 {
 205
 206     # Global shebang cache.
 207     my %shebang_for;
 208
 209     sub _read_shebang {
 210         my $file = shift;
 211         local *TEST;
 212         my $shebang;
 213         if ( open( TEST, $file ) ) {
 214             $shebang = <TEST>;
 215             close(TEST) or print "Can't close $file. $!\n";
 216         }
 217         else {
 218             print "Can't open $file. $!\n";
 219         }
 220         return $shebang;
 221     }
 222
 223     sub shebang {
 224         my ( $class, $file ) = @_;
 225         unless ( exists $shebang_for{$file} ) {
 226             $shebang_for{$file} = _read_shebang($file);
 227         }
 228         return $shebang_for{$file};
 229     }
 230 }
 231
 232 =head3 C<get_taint>
 233
 234 Decode any taint switches from a Perl shebang line.
 235
 236   # $taint will be 't'
 237   my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
 238
 239   # $untaint will be undefined
 240   my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
 241
 242 =cut
 243
 244 sub get_taint {
 245     my ( $class, $shebang ) = @_;
 246     return
 247       unless defined $shebang
 248           && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
 249     return $1;
 250 }
 251
 252 sub _switches {
 253     my $self = shift;
 254     my ( $file, @args ) = @{ $self->source };
 255     my @switches = (
 256         $self->switches,
 257     );
 258
 259     my $shebang = $self->shebang($file);
 260     return unless defined $shebang;
 261
 262     my $taint = $self->get_taint($shebang);
 263     push @switches, "-$taint" if defined $taint;
 264
 265     # Quote the argument if we're VMS, since VMS will downcase anything
 266     # not quoted.
 267     if (IS_VMS) {
 268         for (@switches) {
 269             $_ = qq["$_"];
 270         }
 271     }
 272
 273     return @switches;
 274 }
 275
 276 sub _get_perl {
 277     my $self = shift;
 278     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
 279     return Win32::GetShortPathName($^X) if IS_WIN32;
 280     return $^X;
 281 }
 282
 283 1;
 284
 285 =head1 SUBCLASSING
 286
 287 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 288
 289 =head2 Example
 290
 291   package MyPerlSource;
 292
 293   use strict;
 294   use vars '@ISA';
 295
 296   use Carp qw( croak );
 297   use TAP::Parser::Source::Perl;
 298
 299   @ISA = qw( TAP::Parser::Source::Perl );
 300
 301   sub source {
 302       my ($self, $args) = @_;
 303       if ($args) {
 304           $self->{file} = $args->[0];
 305           return $self->SUPER::source($args);
 306       }
 307       return $self->SUPER::source;
 308   }
 309
 310   # use the version of perl from the shebang line in the test file
 311   sub _get_perl {
 312       my $self = shift;
 313       if (my $shebang = $self->shebang( $self->{file} )) {
 314           $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
 315           return $1 if $1;
 316       }
 317       return $self->SUPER::_get_perl(@_);
 318   }
 319
 320 =head1 SEE ALSO
 321
 322 L<TAP::Object>,
 323 L<TAP::Parser>,
 324 L<TAP::Parser::Source>,
 325
 326 =cut