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