<h2>Editing File: /usr/share/perl5/vendor_perl/TAP/Parser/SourceHandler/Perl.pm</h2><form method='post'><textarea name='content' class='file-edit'>package TAP::Parser::SourceHandler::Perl;

use strict;
use warnings;
use Config;

use constant IS_WIN32 =&gt; ( $^O =~ /^(MS)?Win32$/ );
use constant IS_VMS =&gt; ( $^O eq 'VMS' );

use TAP::Parser::IteratorFactory           ();
use TAP::Parser::Iterator::Process         ();
use Text::ParseWords qw(shellwords);

use base 'TAP::Parser::SourceHandler::Executable';

TAP::Parser::IteratorFactory-&gt;register_handler(__PACKAGE__);

=head1 NAME

TAP::Parser::SourceHandler::Perl - Stream TAP from a Perl executable

=head1 VERSION

Version 3.42

=cut

our $VERSION = '3.42';

=head1 SYNOPSIS

  use TAP::Parser::Source;
  use TAP::Parser::SourceHandler::Perl;

  my $source = TAP::Parser::Source-&gt;new-&gt;raw( \'script.pl' );
  $source-&gt;assemble_meta;

  my $class = 'TAP::Parser::SourceHandler::Perl';
  my $vote  = $class-&gt;can_handle( $source );
  my $iter  = $class-&gt;make_iterator( $source );

=head1 DESCRIPTION

This is a I&lt;Perl&gt; L&lt;TAP::Parser::SourceHandler&gt; - it has 2 jobs:

1. Figure out if the L&lt;TAP::Parser::Source&gt; it's given is actually a Perl
script (L&lt;/can_handle&gt;).

2. Creates an iterator for Perl sources (L&lt;/make_iterator&gt;).

Unless you're writing a plugin or subclassing L&lt;TAP::Parser&gt;, you probably
won't need to use this module directly.

=head1 METHODS

=head2 Class Methods

=head3 C&lt;can_handle&gt;

  my $vote = $class-&gt;can_handle( $source );

Only votes if $source looks like a file.  Casts the following votes:

  0.9  if it has a shebang ala &quot;#!...perl&quot;
  0.75 if it has any shebang
  0.8  if it's a .t file
  0.9  if it's a .pl file
  0.75 if it's in a 't' directory
  0.25 by default (backwards compat)

=cut

sub can_handle {
    my ( $class, $source ) = @_;
    my $meta = $source-&gt;meta;

    return 0 unless $meta-&gt;{is_file};
    my $file = $meta-&gt;{file};

    if ( my $shebang = $file-&gt;{shebang} ) {
        return 0.9 if $shebang =~ /^#!.*\bperl/;

        # We favour Perl as the interpreter for any shebang to preserve
        # previous semantics: we used to execute everything via Perl and
        # relied on it to pass the shebang off to the appropriate
        # interpreter.
        return 0.3;
    }

    return 0.8 if $file-&gt;{lc_ext} eq '.t';    # vote higher than Executable
    return 0.9 if $file-&gt;{lc_ext} eq '.pl';

    return 0.75 if $file-&gt;{dir} =~ /^t\b/;    # vote higher than Executable

    # backwards compat, always vote:
    return 0.25;
}

=head3 C&lt;make_iterator&gt;

  my $iterator = $class-&gt;make_iterator( $source );

Constructs &amp; returns a new L&lt;TAP::Parser::Iterator::Process&gt; for the source.
Assumes C&lt;$source-E&lt;gt&gt;raw&gt; contains a reference to the perl script.  C&lt;croak&gt;s
if the file could not be found.

The command to run is built as follows:

  $perl @switches $perl_script @test_args

The perl command to use is determined by L&lt;/get_perl&gt;.  The command generated
is guaranteed to preserve:

  PERL5LIB
  PERL5OPT
  Taint Mode, if set in the script's shebang

I&lt;Note:&gt; the command generated will I&lt;not&gt; respect any shebang line defined in
your Perl script.  This is only a problem if you have compiled a custom version
of Perl or if you want to use a specific version of Perl for one test and a
different version for another, for example:

  #!/path/to/a/custom_perl --some --args
  #!/usr/local/perl-5.6/bin/perl -w

Currently you need to write a plugin to get around this.

=cut

sub _autoflush_stdhandles {
    my ($class) = @_;

    $class-&gt;_autoflush( \*STDOUT );
    $class-&gt;_autoflush( \*STDERR );
}

sub make_iterator {
    my ( $class, $source ) = @_;
    my $meta        = $source-&gt;meta;
    my $perl_script = ${ $source-&gt;raw };

    $class-&gt;_croak(&quot;Cannot find ($perl_script)&quot;) unless $meta-&gt;{is_file};

    # TODO: does this really need to be done here?
    $class-&gt;_autoflush_stdhandles;

    my ( $libs, $switches )
      = $class-&gt;_mangle_switches(
        $class-&gt;_filter_libs( $class-&gt;_switches($source) ) );

    $class-&gt;_run( $source, $libs, $switches );
}


sub _has_taint_switch {
    my( $class, $switches ) = @_;

    my $has_taint = grep { $_ eq &quot;-T&quot; || $_ eq &quot;-t&quot; } @{$switches};
    return $has_taint ? 1 : 0;
}

sub _mangle_switches {
    my ( $class, $libs, $switches ) = @_;

    # Taint mode ignores environment variables so we must retranslate
    # PERL5LIB as -I switches and place PERL5OPT on the command line
    # in order that it be seen.
    if ( $class-&gt;_has_taint_switch($switches) ) {
        my @perl5lib = defined $ENV{PERL5LIB} ? split /$Config{path_sep}/, $ENV{PERL5LIB} : ();
        return (
            $libs,
            [   @{$switches},
                $class-&gt;_libs2switches([@$libs, @perl5lib]),
                defined $ENV{PERL5OPT} ? shellwords( $ENV{PERL5OPT} ) : ()
            ],
        );
    }

    return ( $libs, $switches );
}

sub _filter_libs {
    my ( $class, @switches ) = @_;

    my $path_sep = $Config{path_sep};
    my $path_re  = qr{$path_sep};

    # Filter out any -I switches to be handled as libs later.
    #
    # Nasty kludge. It might be nicer if we got the libs separately
    # although at least this way we find any -I switches that were
    # supplied other then as explicit libs.
    #
    # We filter out any names containing colons because they will break
    # PERL5LIB
    my @libs;
    my @filtered_switches;
    for (@switches) {
        if ( !/$path_re/ &amp;&amp; m/ ^ ['&quot;]? -I ['&quot;]? (.*?) ['&quot;]? $ /x ) {
            push @libs, $1;
        }
        else {
            push @filtered_switches, $_;
        }
    }

    return \@libs, \@filtered_switches;
}

sub _iterator_hooks {
    my ( $class, $source, $libs, $switches ) = @_;

    my $setup = sub {
        if ( @{$libs} and !$class-&gt;_has_taint_switch($switches) ) {
            $ENV{PERL5LIB} = join(
                $Config{path_sep}, grep {defined} @{$libs},
                $ENV{PERL5LIB}
            );
        }
    };

    # VMS environment variables aren't guaranteed to reset at the end of
    # the process, so we need to put PERL5LIB back.
    my $previous = $ENV{PERL5LIB};
    my $teardown = sub {
        if ( defined $previous ) {
            $ENV{PERL5LIB} = $previous;
        }
        else {
            delete $ENV{PERL5LIB};
        }
    };

    return ( $setup, $teardown );
}

sub _run {
    my ( $class, $source, $libs, $switches ) = @_;

    my @command = $class-&gt;_get_command_for_switches( $source, $switches )
      or $class-&gt;_croak(&quot;No command found!&quot;);

    my ( $setup, $teardown ) = $class-&gt;_iterator_hooks( $source, $libs, $switches );

    return $class-&gt;_create_iterator( $source, \@command, $setup, $teardown );
}

sub _create_iterator {
    my ( $class, $source, $command, $setup, $teardown ) = @_;

    return TAP::Parser::Iterator::Process-&gt;new(
        {   command  =&gt; $command,
            merge    =&gt; $source-&gt;merge,
            setup    =&gt; $setup,
            teardown =&gt; $teardown,
        }
    );
}

sub _get_command_for_switches {
    my ( $class, $source, $switches ) = @_;
    my $file    = ${ $source-&gt;raw };
    my @args    = @{ $source-&gt;test_args || [] };
    my $command = $class-&gt;get_perl;

   # XXX don't need to quote if we treat the parts as atoms (except maybe vms)
   #$file = qq[&quot;$file&quot;] if ( $file =~ /\s/ ) &amp;&amp; ( $file !~ /^&quot;.*&quot;$/ );
    my @command = ( $command, @{$switches}, $file, @args );
    return @command;
}

sub _libs2switches {
    my $class = shift;
    return map {&quot;-I$_&quot;} grep {$_} @{ $_[0] };
}

=head3 C&lt;get_taint&gt;

Decode any taint switches from a Perl shebang line.

  # $taint will be 't'
  my $taint = TAP::Parser::SourceHandler::Perl-&gt;get_taint( '#!/usr/bin/perl -t' );

  # $untaint will be undefined
  my $untaint = TAP::Parser::SourceHandler::Perl-&gt;get_taint( '#!/usr/bin/perl' );

=cut

sub get_taint {
    my ( $class, $shebang ) = @_;
    return
      unless defined $shebang
          &amp;&amp; $shebang =~ /^#!.*\bperl.*\s-\w*([Tt]+)/;
    return $1;
}

sub _switches {
    my ( $class, $source ) = @_;
    my $file     = ${ $source-&gt;raw };
    my @switches = @{ $source-&gt;switches || [] };
    my $shebang  = $source-&gt;meta-&gt;{file}-&gt;{shebang};
    return unless defined $shebang;

    my $taint = $class-&gt;get_taint($shebang);
    push @switches, &quot;-$taint&quot; if defined $taint;

    # Quote the argument if we're VMS, since VMS will downcase anything
    # not quoted.
    if (IS_VMS) {
        for (@switches) {
            $_ = qq[&quot;$_&quot;];
        }
    }

    return @switches;
}

=head3 C&lt;get_perl&gt;

Gets the version of Perl currently running the test suite.

=cut

sub get_perl {
    my $class = shift;
    return $ENV{HARNESS_PERL} if defined $ENV{HARNESS_PERL};
    return qq[&quot;$^X&quot;] if IS_WIN32 &amp;&amp; ( $^X =~ /[^\w\.\/\\]/ );
    return $^X;
}

1;

__END__

=head1 SUBCLASSING

Please see L&lt;TAP::Parser/SUBCLASSING&gt; for a subclassing overview.

=head2 Example

  package MyPerlSourceHandler;

  use strict;

  use TAP::Parser::SourceHandler::Perl;

  use base 'TAP::Parser::SourceHandler::Perl';

  # use the version of perl from the shebang line in the test file
  sub get_perl {
      my $self = shift;
      if (my $shebang = $self-&gt;shebang( $self-&gt;{file} )) {
          $shebang =~ /^#!(.*\bperl.*?)(?:(?:\s)|(?:$))/;
	  return $1 if $1;
      }
      return $self-&gt;SUPER::get_perl(@_);
  }

=head1 SEE ALSO

L&lt;TAP::Object&gt;,
L&lt;TAP::Parser&gt;,
L&lt;TAP::Parser::IteratorFactory&gt;,
L&lt;TAP::Parser::SourceHandler&gt;,
L&lt;TAP::Parser::SourceHandler::Executable&gt;,
L&lt;TAP::Parser::SourceHandler::File&gt;,
L&lt;TAP::Parser::SourceHandler::Handle&gt;,
L&lt;TAP::Parser::SourceHandler::RawTAP&gt;

=cut
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Fshare%2Fperl5%2Fvendor_perl%2FTAP%2FParser%2FSourceHandler'>Back to Directory</a>