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