1package TAP::Parser::SourceHandler::Perl; 2 3use strict; 4use warnings; 5use Config; 6 7use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ ); 8use constant IS_VMS => ( $^O eq 'VMS' ); 9 10use TAP::Parser::IteratorFactory (); 11use TAP::Parser::Iterator::Process (); 12use Text::ParseWords qw(shellwords); 13 14use base 'TAP::Parser::SourceHandler::Executable'; 15 16TAP::Parser::IteratorFactory->register_handler(__PACKAGE__); 17 18=head1 NAME 19 20TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable 21 22=head1 VERSION 23 24Version 3.48 25 26=cut 27 28our $VERSION = '3.48'; 29 30=head1 SYNOPSIS 31 32 use TAP::Parser::Source; 33 use TAP::Parser::SourceHandler::Perl; 34 35 my $source = TAP::Parser::Source->new->raw( \'script.pl' ); 36 $source->assemble_meta; 37 38 my $class = 'TAP::Parser::SourceHandler::Perl'; 39 my $vote = $class->can_handle( $source ); 40 my $iter = $class->make_iterator( $source ); 41 42=head1 DESCRIPTION 43 44This is a I<Perl> L<TAP::Parser::SourceHandler> - it has 2 jobs: 45 461. Figure out if the L<TAP::Parser::Source> it's given is actually a Perl 47script (L</can_handle>). 48 492. Creates an iterator for Perl sources (L</make_iterator>). 50 51Unless you're writing a plugin or subclassing L<TAP::Parser>, you probably 52won't need to use this module directly. 53 54=head1 METHODS 55 56=head2 Class Methods 57 58=head3 C<can_handle> 59 60 my $vote = $class->can_handle( $source ); 61 62Only votes if $source looks like a file. Casts the following votes: 63 64 0.9 if it has a shebang ala "#!...perl" 65 0.3 if it has any shebang 66 0.8 if it's a .t file 67 0.9 if it's a .pl file 68 0.75 if it's in a 't' directory 69 0.25 by default (backwards compat) 70 71=cut 72 73sub can_handle { 74 my ( $class, $source ) = @_; 75 my $meta = $source->meta; 76 77 return 0 unless $meta->{is_file}; 78 my $file = $meta->{file}; 79 80 my $shebang = $file->{shebang} || ''; 81 82 if ( $shebang =~ /^#!/ ) { 83 return 0.9 if $shebang =~ /^#!.*\bperl/; 84 85 # We favour Perl as the interpreter for any shebang to preserve 86 # previous semantics: we used to execute everything via Perl and 87 # relied on it to pass the shebang off to the appropriate 88 # interpreter. 89 return 0.3; 90 } 91 92 return 0.8 if $file->{lc_ext} eq '.t'; # vote higher than Executable 93 return 0.9 if $file->{lc_ext} eq '.pl'; 94 95 return 0.75 if $file->{dir} =~ /^t\b/; # vote higher than Executable 96 97 # backwards compat, always vote: 98 return 0.25; 99} 100 101=head3 C<make_iterator> 102 103 my $iterator = $class->make_iterator( $source ); 104 105Constructs & returns a new L<TAP::Parser::Iterator::Process> for the source. 106Assumes C<$source-E<gt>raw> contains a reference to the perl script. C<croak>s 107if the file could not be found. 108 109The command to run is built as follows: 110 111 $perl @switches $perl_script @test_args 112 113The perl command to use is determined by L</get_perl>. The command generated 114is guaranteed to preserve: 115 116 PERL5LIB 117 PERL5OPT 118 Taint Mode, if set in the script's shebang 119 120I<Note:> the command generated will I<not> respect any shebang line defined in 121your Perl script. This is only a problem if you have compiled a custom version 122of Perl or if you want to use a specific version of Perl for one test and a 123different version for another, for example: 124 125 #!/path/to/a/custom_perl --some --args 126 #!/usr/local/perl-5.6/bin/perl -w 127 128Currently you need to write a plugin to get around this. 129 130=cut 131 132sub _autoflush_stdhandles { 133 my ($class) = @_; 134 135 $class->_autoflush( \*STDOUT ); 136 $class->_autoflush( \*STDERR ); 137} 138 139sub make_iterator { 140 my ( $class, $source ) = @_; 141 my $meta = $source->meta; 142 my $perl_script = ${ $source->raw }; 143 144 $class->_croak("Cannot find ($perl_script)") unless $meta->{is_file}; 145 146 # TODO: does this really need to be done here? 147 $class->_autoflush_stdhandles; 148 149 my ( $libs, $switches ) 150 = $class->_mangle_switches( 151 $class->_filter_libs( $class->_switches($source) ) ); 152 153 $class->_run( $source, $libs, $switches ); 154} 155 156 157sub _has_taint_switch { 158 my( $class, $switches ) = @_; 159 160 my $has_taint = grep { $_ eq "-T" || $_ eq "-t" } @{$switches}; 161 return $has_taint ? 1 : 0; 162} 163 164sub _mangle_switches { 165 my ( $class, $libs, $switches ) = @_; 166 167 # Taint mode ignores environment variables so we must retranslate 168 # PERL5LIB as -I switches and place PERL5OPT on the command line 169 # in order that it be seen. 170 if ( $class->_has_taint_switch($switches) ) { 171 my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : (); 172 return ( 173 $libs, 174 [ @{$switches}, 175 $class->_libs2switches([@$libs, @perl5lib]), 176 defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : () 177 ], 178 ); 179 } 180 181 return ( $libs, $switches ); 182} 183 184sub _filter_libs { 185 my ( $class, @switches ) = @_; 186 187 my $path_sep = $Config{path_sep}; 188 my $path_re = qr{$path_sep}; 189 190 # Filter out any -I switches to be handled as libs later. 191 # 192 # Nasty kludge. It might be nicer if we got the libs separately 193 # although at least this way we find any -I switches that were 194 # supplied other then as explicit libs. 195 # 196 # We filter out any names containing colons because they will break 197 # PERL5LIB 198 my @libs; 199 my @filtered_switches; 200 for (@switches) { 201 if ( !/$path_re/ && m/ ^ ['"]? -I ['"]? (.*?) ['"]? $ /x ) { 202 push @libs, $1; 203 } 204 else { 205 push @filtered_switches, $_; 206 } 207 } 208 209 return \@libs, \@filtered_switches; 210} 211 212sub _iterator_hooks { 213 my ( $class, $source, $libs, $switches ) = @_; 214 215 my $setup = sub { 216 if ( @{$libs} and !$class->_has_taint_switch($switches) ) { 217 $ENV{PERL5LIB} = join( 218 $Config{path_sep}, grep {defined} @{$libs}, 219 $ENV{PERL5LIB} 220 ); 221 } 222 }; 223 224 # VMS environment variables aren't guaranteed to reset at the end of 225 # the process, so we need to put PERL5LIB back. 226 my $previous = $ENV{PERL5LIB}; 227 my $teardown = sub { 228 if ( defined $previous ) { 229 $ENV{PERL5LIB} = $previous; 230 } 231 else { 232 delete $ENV{PERL5LIB}; 233 } 234 }; 235 236 return ( $setup, $teardown ); 237} 238 239sub _run { 240 my ( $class, $source, $libs, $switches ) = @_; 241 242 my @command = $class->_get_command_for_switches( $source, $switches ) 243 or $class->_croak("No command found!"); 244 245 my ( $setup, $teardown ) = $class->_iterator_hooks( $source, $libs, $switches ); 246 247 return $class->_create_iterator( $source, \@command, $setup, $teardown ); 248} 249 250sub _create_iterator { 251 my ( $class, $source, $command, $setup, $teardown ) = @_; 252 253 return TAP::Parser::Iterator::Process->new( 254 { command => $command, 255 merge => $source->merge, 256 setup => $setup, 257 teardown => $teardown, 258 } 259 ); 260} 261 262sub _get_command_for_switches { 263 my ( $class, $source, $switches ) = @_; 264 my $file = ${ $source->raw }; 265 my @args = @{ $source->test_args || [] }; 266 my $command = $class->get_perl; 267 268 # XXX don't need to quote if we treat the parts as atoms (except maybe vms) 269 #$file = qq["$file"] if ( $file =~ /\s/ ) && ( $file !~ /^".*"$/ ); 270 my @command = ( $command, @{$switches}, $file, @args ); 271 return @command; 272} 273 274sub _libs2switches { 275 my $class = shift; 276 return map {"-I$_"} grep {$_} @{ $_[0] }; 277} 278 279=head3 C<get_taint> 280 281Decode any taint switches from a Perl shebang line. 282 283 # $taint will be 't' 284 my $taint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl -t' ); 285 286 # $untaint will be undefined 287 my $untaint = TAP::Parser::SourceHandler::Perl->get_taint( '#!/usr/bin/perl' ); 288 289=cut 290 291sub get_taint { 292 my ( $class, $shebang ) = @_; 293 return 294 unless defined $shebang 295 && $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/; 296 return $1; 297} 298 299sub _switches { 300 my ( $class, $source ) = @_; 301 my $file = ${ $source->raw }; 302 my @switches = @{ $source->switches || [] }; 303 my $shebang = $source->meta->{file}->{shebang}; 304 return unless defined $shebang; 305 306 my $taint = $class->get_taint($shebang); 307 push @switches, "-$taint" if defined $taint; 308 309 # Quote the argument if we're VMS, since VMS will downcase anything 310 # not quoted. 311 if (IS_VMS) { 312 for (@switches) { 313 $_ = qq["$_"]; 314 } 315 } 316 317 return @switches; 318} 319 320=head3 C<get_perl> 321 322Gets the version of Perl currently running the test suite. 323 324=cut 325 326sub get_perl { 327 my $class = shift; 328 return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL}; 329 return qq["$^X"] if IS_WIN32 && ( $^X =~ /[^\w\.\/\\]/ ); 330 return $^X; 331} 332 3331; 334 335__END__ 336 337=head1 SUBCLASSING 338 339Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview. 340 341=head2 Example 342 343 package MyPerlSourceHandler; 344 345 use strict; 346 347 use TAP::Parser::SourceHandler::Perl; 348 349 use base 'TAP::Parser::SourceHandler::Perl'; 350 351 # use the version of perl from the shebang line in the test file 352 sub get_perl { 353 my $self = shift; 354 if (my $shebang = $self->shebang( $self->{file} )) { 355 $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/; 356 return $1 if $1; 357 } 358 return $self->SUPER::get_perl(@_); 359 } 360 361=head1 SEE ALSO 362 363L<TAP::Object>, 364L<TAP::Parser>, 365L<TAP::Parser::IteratorFactory>, 366L<TAP::Parser::SourceHandler>, 367L<TAP::Parser::SourceHandler::Executable>, 368L<TAP::Parser::SourceHandler::File>, 369L<TAP::Parser::SourceHandler::Handle>, 370L<TAP::Parser::SourceHandler::RawTAP> 371 372=cut 373