tools/perl-5.8.0/lib/site_perl/5.8.0/Psh/Strategy/Perlscript.pm

package Psh::Strategy::Perlscript;

require Psh::Strategy;
require Psh::Util;

=item * C<perlscript>

If (1) the first word of the input line matches the
name of a file found in one of the directories listed
in the path ($ENV{PATH}), and (2) that file starts
with #!/.../perl, and (3) that perl is the same as the
Perl under which psh is running, psh will fork and run
the script using the already-loaded Perl interpreter.
The idea is to save the exec half of the fork-exec
that the executable strategy would do; typically the
exec is more expensive. Right now this strategy can
only handle the -w command-line switch on the #! line.
Note this strategy only makes sense before the
"executable" strategy; if it came after, it could
never trigger.

=cut

@Psh::Strategy::Perlscript::ISA=('Psh::Strategy');

sub new { Psh::Strategy::new(@_) }

sub consumes {
        return Psh::Strategy::CONSUME_TOKENS;
}

sub runs_before {
        return qw(executable);
}

#
# bool matches_perl_binary(string FILENAME)
#
# Returns true if FILENAME referes directly or indirectly to the
# current perl executable
#

sub matches_perl_binary
{
        my ($filename) = @_;
        require Config;

        #
        # Chase down symbolic links, but don't crash on systems that don't
        # have them:
        #

        if ($Config::Config{d_readlink}) {
                my $newfile;
                while ($newfile = readlink($filename)) { $filename = $newfile; }
        }

        if ($filename eq $Config::Config{perlpath}) { return 1; }

        my ($perldev,$perlino) = (stat($Config::Config{perlpath}))[0,1];
        my ($dev,$ino) = (stat($filename))[0,1];

        #
        # TODO: Does the following work on non-Unix OS ?
        #

        if ($perldev == $dev and $perlino == $ino) { return 1; }

        return 0;
}

sub applies {
        my $script = Psh::Util::which(@{$_[2]}->[0]);
        return '' unless $script;

        #
        # let's see if it really looks like a perl script
        #
        my $firstline;
        if (open(FILE,"< $script")) {
                $firstline= <FILE>;
                close(FILE);
        }
        else {
                return;
        }
        chomp $firstline;

        my $filename;
        my $switches;

        if (($filename,$switches) =
                ($firstline =~ m|^\#!\s*(/.*perl)(\s+.+)?$|go)
                and matches_perl_binary($filename)) {
                my $possibleMatch = $script;
                my %bangLineOptions = ();

                if( $switches) {
                        $switches=~ s/^\s+//go;
                        local @ARGV = split(' ', $switches);

                        #
                        # All perl command-line options that take aruments as of
                        # Perl 5.00503:
                        #

                        require Getopt::Std;
                        getopt('DeiFlimMx', \%bangLineOptions);
                }

                if ($bangLineOptions{w}) {
                        $possibleMatch .= " warnings";
                        delete $bangLineOptions{w};
                }

                #
                # TODO: We could handle more options. [There are some we
                # can't. -d, -n and -p are popular ones that would be tough.]
                #

                if (scalar(keys %bangLineOptions) > 0) {
                        print_debug("[[perlscript: skip $script, options $switches.]]\n");
                        return '';
                }
                return $possibleMatch;
        }
        return '';
}


sub execute {
        my ($script, @options) = split(' ',$_[3]);
        my @arglist = @{$_[2]};

        shift @arglist; # Get rid of script name
        my $fgflag = 1;

        if (scalar(@arglist) > 0) {
                my $lastarg = pop @arglist;

                if ($lastarg =~ m/\&$/) {
                        $fgflag = 0;
                        $lastarg =~ s/\&$//;
                }

                if ($lastarg) { push @arglist, $lastarg; }
        }

        print_debug("[[perlscript $script, options @options, args @arglist.]]\n");

        my $pid;

        my %opts = ();
        foreach (@options) { $opts{$_} = 1; }


        return (1,sub {
                                package main;
                                # TODO: Is it possible/desirable to put main in the pristine
                                # state that it typically is in when a script starts up,
                                # i.e. undefine all routines and variables that the user has set?
                        local @ARGV = @arglist;
                        local $^W;

                        if ($opts{warnings}) { $^W = 1; }
                        else                 { $^W = 0; }

                        local $Psh::tmp= do $script;

                        CORE::exit !$Psh::tmp;
                }, [], 1, undef);
}

1;