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.06
  20
  21 =cut
  22
  23 $VERSION = '3.06';
  24
  25 =head1 DESCRIPTION
  26
  27 Takes a filename and hopefully returns a stream from it.  The filename should
  28 be the name of a Perl program.
  29
  30 Note that this is a subclass of L<TAP::Parser::Source>.  See that module for
  31 more methods.
  32
  33 =head1 SYNOPSIS
  34
  35     use TAP::Parser::Source::Perl;
  36     my $perl = TAP::Parser::Source::Perl->new;
  37     my $stream = $perl->source( [ $filename, @args ] )->get_stream;
  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 =cut
  59
  60 sub source {
  61     my $self = shift;
  62     $self->_croak("Cannot find ($_[0][0])")
  63       if @_ && !-f $_[0][0];
  64     return $self->SUPER::source(@_);
  65 }
  66
  67 =head3 C<switches>
  68
  69   my $switches = $perl->switches;
  70   my @switches = $perl->switches;
  71   $perl->switches( \@switches );
  72
  73 Getter/setter for the additional switches to pass to the perl executable.  One
  74 common switch would be to set an include directory:
  75
  76   $perl->switches( ['-Ilib'] );
  77
  78 =cut
  79
  80 sub switches {
  81     my $self = shift;
  82     unless (@_) {
  83         return wantarray ? @{ $self->{switches} } : $self->{switches};
  84     }
  85     my $switches = shift;
  86     $self->{switches} = [@$switches];    # force a copy
  87     return $self;
  88 }
  89
  90 ##############################################################################
  91
  92 =head3 C<get_stream>
  93
  94  my $stream = $source->get_stream;
  95
  96 Returns a stream of the output generated by executing C<source>.
  97
  98 =cut
  99
 100 sub get_stream {
 101     my $self = shift;
 102
 103     my @extra_libs;
 104
 105     my @switches = $self->_switches;
 106     my $path_sep = $Config{path_sep};
 107     my $path_pat = qr{$path_sep};
 108
 109     # Nasty kludge. It might be nicer if we got the libs separately
 110     # although at least this way we find any -I switches that were
 111     # supplied other then as explicit libs.
 112     # We filter out any names containing colons because they will break
 113     # PERL5LIB
 114     my @libs;
 115     for ( grep { $_ !~ $path_pat } @switches ) {
 116         push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
 117     }
 118
 119     my $previous = $ENV{PERL5LIB};
 120     if ($previous) {
 121         push @libs, split( $path_pat, $previous );
 122     }
 123
 124     my $setup = sub {
 125         if (@libs) {
 126             $ENV{PERL5LIB} = join( $path_sep, @libs );
 127         }
 128     };
 129
 130     # Cargo culted from comments seen elsewhere about VMS / environment
 131     # variables. I don't know if this is actually necessary.
 132     my $teardown = sub {
 133         if ($previous) {
 134             $ENV{PERL5LIB} = $previous;
 135         }
 136         else {
 137             delete $ENV{PERL5LIB};
 138         }
 139     };
 140
 141     # Taint mode ignores environment variables so we must retranslate
 142     # PERL5LIB as -I switches and place PERL5OPT on the command line
 143     # in order that it be seen.
 144     if ( grep { $_ eq "-T" } @switches ) {
 145         push @switches,
 146           $self->_libs2switches(
 147             split $path_pat,
 148             $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
 149           );
 150
 151         push @switches, $ENV{PERL5OPT} || ();
 152     }
 153
 154     my @command = $self->_get_command_for_switches(@switches)
 155       or $self->_croak("No command found!");
 156
 157     return TAP::Parser::Iterator->new(
 158         {   command  => \@command,
 159             merge    => $self->merge,
 160             setup    => $setup,
 161             teardown => $teardown,
 162         }
 163     );
 164 }
 165
 166 sub _get_command_for_switches {
 167     my $self     = shift;
 168     my @switches = @_;
 169     my ( $file, @args ) = @{ $self->source };
 170     my $command = $self->_get_perl;
 171
 172     $file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
 173     my @command = ( $command, @switches, $file, @args );
 174     return @command;
 175 }
 176
 177 sub _get_command {
 178     my $self = shift;
 179     return $self->_get_command_for_switches( $self->_switches );
 180 }
 181
 182 sub _libs2switches {
 183     my $self = shift;
 184     return map {"-I$_"} grep {$_} @_;
 185 }
 186
 187 =head3 C<shebang>
 188
 189 Get the shebang line for a script file.
 190
 191     my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
 192
 193 May be called as a class method
 194
 195 =cut
 196
 197 {
 198
 199     # Global shebang cache.
 200     my %shebang_for;
 201
 202     sub _read_shebang {
 203         my $file = shift;
 204         local *TEST;
 205         my $shebang;
 206         if ( open( TEST, $file ) ) {
 207             $shebang = <TEST>;
 208             close(TEST) or print "Can't close $file. $!\n";
 209         }
 210         else {
 211             print "Can't open $file. $!\n";
 212         }
 213         return $shebang;
 214     }
 215
 216     sub shebang {
 217         my ( $class, $file ) = @_;
 218         unless ( exists $shebang_for{$file} ) {
 219             $shebang_for{$file} = _read_shebang($file);
 220         }
 221         return $shebang_for{$file};
 222     }
 223 }
 224
 225 =head3 C<get_taint>
 226
 227 Decode any taint switches from a Perl shebang line.
 228
 229     # $taint will be 't'
 230     my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
 231
 232     # $untaint will be undefined
 233     my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
 234
 235 =cut
 236
 237 sub get_taint {
 238     my ( $class, $shebang ) = @_;
 239     return
 240       unless defined $shebang
 241           && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
 242     return $1;
 243 }
 244
 245 sub _switches {
 246     my $self = shift;
 247     my ( $file, @args ) = @{ $self->source };
 248     my @switches = (
 249         $self->switches,
 250     );
 251
 252     my $shebang = $self->shebang($file);
 253     return unless defined $shebang;
 254
 255     my $taint = $self->get_taint($shebang);
 256     push @switches, "-$taint" if defined $taint;
 257
 258     # Quote the argument if there's any whitespace in it, or if
 259     # we're VMS, since VMS requires all parms quoted.  Also, don't quote
 260     # it if it's already quoted.
 261     for (@switches) {
 262         $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
 263     }
 264
 265     my %found_switch = map { $_ => 0 } @switches;
 266
 267     # remove duplicate switches
 268     @switches
 269       = grep { defined $_ && $_ ne '' && !$found_switch{$_}++ } @switches;
 270     return @switches;
 271 }
 272
 273 sub _get_perl {
 274     my $proto = 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;