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.14
  22
  23 =cut
  24
  25 $VERSION = '3.14';
  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 @extra_libs;
 110
 111     my @switches = $self->_switches;
 112     my $path_sep = $Config{path_sep};
 113     my $path_pat = qr{$path_sep};
 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     # We filter out any names containing colons because they will break
 119     # PERL5LIB
 120     my @libs;
 121     for ( grep { $_ !~ $path_pat } @switches ) {
 122         push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
 123     }
 124
 125     my $previous = $ENV{PERL5LIB};
 126     if ($previous) {
 127         push @libs, split( $path_pat, $previous );
 128     }
 129
 130     my $setup = sub {
 131         if (@libs) {
 132             $ENV{PERL5LIB} = join( $path_sep, @libs );
 133         }
 134     };
 135
 136     # Cargo culted from comments seen elsewhere about VMS / environment
 137     # variables. I don't know if this is actually necessary.
 138     my $teardown = sub {
 139         if ($previous) {
 140             $ENV{PERL5LIB} = $previous;
 141         }
 142         else {
 143             delete $ENV{PERL5LIB};
 144         }
 145     };
 146
 147     # Taint mode ignores environment variables so we must retranslate
 148     # PERL5LIB as -I switches and place PERL5OPT on the command line
 149     # in order that it be seen.
 150     if ( grep { $_ eq "-T" || $_ eq "-t" } @switches ) {
 151         push @switches,
 152           $self->_libs2switches(
 153             split $path_pat,
 154             $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
 155           );
 156
 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 there's any whitespace in it, or if
 266     # we're VMS, since VMS requires all parms quoted.  Also, don't quote
 267     # it if it's already quoted.
 268     for (@switches) {
 269         $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
 270     }
 271
 272     return @switches;
 273 }
 274
 275 sub _get_perl {
 276     my $self = shift;
 277     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
 278     return Win32::GetShortPathName($^X) if IS_WIN32;
 279     return $^X;
 280 }
 281
 282 1;
 283
 284 =head1 SUBCLASSING
 285
 286 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 287
 288 =head2 Example
 289
 290   package MyPerlSource;
 291
 292   use strict;
 293   use vars '@ISA';
 294
 295   use Carp qw( croak );
 296   use TAP::Parser::Source::Perl;
 297
 298   @ISA = qw( TAP::Parser::Source::Perl );
 299
 300   sub source {
 301       my ($self, $args) = @_;
 302       if ($args) {
 303           $self->{file} = $args->[0];
 304           return $self->SUPER::source($args);
 305       }
 306       return $self->SUPER::source;
 307   }
 308
 309   # use the version of perl from the shebang line in the test file
 310   sub _get_perl {
 311       my $self = shift;
 312       if (my $shebang = $self->shebang( $self->{file} )) {
 313           $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
 314           return $1 if $1;
 315       }
 316       return $self->SUPER::_get_perl(@_);
 317   }
 318
 319 =head1 SEE ALSO
 320
 321 L<TAP::Object>,
 322 L<TAP::Parser>,
 323 L<TAP::Parser::Source>,
 324
 325 =cut