git.maemo.org Git - dh-make-perl/blob - dev/arm/libtest-harness-perl/libtest-harness-perl-3.12/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.12
  20
  21 =cut
  22
  23 $VERSION = '3.12';
  24
  25 =head1 SYNOPSIS
  26
  27   use TAP::Parser::Source::Perl;
  28   my $perl = TAP::Parser::Source::Perl->new({ parser => $parser });
  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({ parser => $parser });
  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;
  97
  98 Returns a stream of the output generated by executing C<source>.
  99
 100 =cut
 101
 102 sub get_stream {
 103     my $self = shift;
 104
 105     my @extra_libs;
 106
 107     my @switches = $self->_switches;
 108     my $path_sep = $Config{path_sep};
 109     my $path_pat = qr{$path_sep};
 110
 111     # Nasty kludge. It might be nicer if we got the libs separately
 112     # although at least this way we find any -I switches that were
 113     # supplied other then as explicit libs.
 114     # We filter out any names containing colons because they will break
 115     # PERL5LIB
 116     my @libs;
 117     for ( grep { $_ !~ $path_pat } @switches ) {
 118         push @libs, $1 if / ^ ['"]? -I (.*?) ['"]? $ /x;
 119     }
 120
 121     my $previous = $ENV{PERL5LIB};
 122     if ($previous) {
 123         push @libs, split( $path_pat, $previous );
 124     }
 125
 126     my $setup = sub {
 127         if (@libs) {
 128             $ENV{PERL5LIB} = join( $path_sep, @libs );
 129         }
 130     };
 131
 132     # Cargo culted from comments seen elsewhere about VMS / environment
 133     # variables. I don't know if this is actually necessary.
 134     my $teardown = sub {
 135         if ($previous) {
 136             $ENV{PERL5LIB} = $previous;
 137         }
 138         else {
 139             delete $ENV{PERL5LIB};
 140         }
 141     };
 142
 143     # Taint mode ignores environment variables so we must retranslate
 144     # PERL5LIB as -I switches and place PERL5OPT on the command line
 145     # in order that it be seen.
 146     if ( grep { $_ eq "-T" } @switches ) {
 147         push @switches,
 148           $self->_libs2switches(
 149             split $path_pat,
 150             $ENV{PERL5LIB} || $ENV{PERLLIB} || ''
 151           );
 152
 153         push @switches, $ENV{PERL5OPT} || ();
 154     }
 155
 156     my @command = $self->_get_command_for_switches(@switches)
 157       or $self->_croak("No command found!");
 158
 159     return $self->{parser}->make_iterator(
 160         {   command  => \@command,
 161             merge    => $self->merge,
 162             setup    => $setup,
 163             teardown => $teardown,
 164         }
 165     );
 166 }
 167
 168 sub _get_command_for_switches {
 169     my $self     = shift;
 170     my @switches = @_;
 171     my ( $file, @args ) = @{ $self->source };
 172     my $command = $self->_get_perl;
 173
 174 # XXX we never need to quote if we treat the parts as atoms (except maybe vms)
 175 #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ );
 176     my @command = ( $command, @switches, $file, @args );
 177     return @command;
 178 }
 179
 180 sub _get_command {
 181     my $self = shift;
 182     return $self->_get_command_for_switches( $self->_switches );
 183 }
 184
 185 sub _libs2switches {
 186     my $self = shift;
 187     return map {"-I$_"} grep {$_} @_;
 188 }
 189
 190 =head3 C<shebang>
 191
 192 Get the shebang line for a script file.
 193
 194   my $shebang = TAP::Parser::Source::Perl->shebang( $some_script );
 195
 196 May be called as a class method
 197
 198 =cut
 199
 200 {
 201
 202     # Global shebang cache.
 203     my %shebang_for;
 204
 205     sub _read_shebang {
 206         my $file = shift;
 207         local *TEST;
 208         my $shebang;
 209         if ( open( TEST, $file ) ) {
 210             $shebang = <TEST>;
 211             close(TEST) or print "Can't close $file. $!\n";
 212         }
 213         else {
 214             print "Can't open $file. $!\n";
 215         }
 216         return $shebang;
 217     }
 218
 219     sub shebang {
 220         my ( $class, $file ) = @_;
 221         unless ( exists $shebang_for{$file} ) {
 222             $shebang_for{$file} = _read_shebang($file);
 223         }
 224         return $shebang_for{$file};
 225     }
 226 }
 227
 228 =head3 C<get_taint>
 229
 230 Decode any taint switches from a Perl shebang line.
 231
 232   # $taint will be 't'
 233   my $taint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl -t' );
 234
 235   # $untaint will be undefined
 236   my $untaint = TAP::Parser::Source::Perl->get_taint( '#!/usr/bin/perl' );
 237
 238 =cut
 239
 240 sub get_taint {
 241     my ( $class, $shebang ) = @_;
 242     return
 243       unless defined $shebang
 244           && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
 245     return $1;
 246 }
 247
 248 sub _switches {
 249     my $self = shift;
 250     my ( $file, @args ) = @{ $self->source };
 251     my @switches = (
 252         $self->switches,
 253     );
 254
 255     my $shebang = $self->shebang($file);
 256     return unless defined $shebang;
 257
 258     my $taint = $self->get_taint($shebang);
 259     push @switches, "-$taint" if defined $taint;
 260
 261     # Quote the argument if there's any whitespace in it, or if
 262     # we're VMS, since VMS requires all parms quoted.  Also, don't quote
 263     # it if it's already quoted.
 264     for (@switches) {
 265         $_ = qq["$_"] if ( ( /\s/ || IS_VMS ) && !/^".*"$/ );
 266     }
 267
 268     return @switches;
 269 }
 270
 271 sub _get_perl {
 272     my $self = shift;
 273     return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
 274     return Win32::GetShortPathName($^X) if IS_WIN32;
 275     return $^X;
 276 }
 277
 278 1;
 279
 280
 281 =head1 SUBCLASSING
 282
 283 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 284
 285 =head2 Example
 286
 287   package MyPerlSource;
 288
 289   use strict;
 290   use vars '@ISA';
 291
 292   use Carp qw( croak );
 293   use TAP::Parser::Source::Perl;
 294
 295   @ISA = qw( TAP::Parser::Source::Perl );
 296
 297   sub source {
 298       my ($self, $args) = @_;
 299       if ($args) {
 300           $self->{file} = $args->[0];
 301           return $self->SUPER::source($args);
 302       }
 303       return $self->SUPER::source;
 304   }
 305
 306   # use the version of perl from the shebang line in the test file
 307   sub _get_perl {
 308       my $self = shift;
 309       if (my $shebang = $self->shebang( $self->{file} )) {
 310           $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
 311           return $1 if $1;
 312       }
 313       return $self->SUPER::_get_perl(@_);
 314   }
 315
 316 =head1 SEE ALSO
 317
 318 L<TAP::Object>,
 319 L<TAP::Parser>,
 320 L<TAP::Parser::Source>,
 321
 322 =cut