package Psh
::Strategy
::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
@Psh::Strategy
::Perlscript
::ISA
=('Psh::Strategy');
sub new
{ Psh
::Strategy
::new
(@_) }
return Psh
::Strategy
::CONSUME_TOKENS
;
# bool matches_perl_binary(string FILENAME)
# Returns true if FILENAME referes directly or indirectly to the
# current perl executable
# Chase down symbolic links, but don't crash on systems that don't
if ($Config::Config
{d_readlink
}) {
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; }
my $script = Psh
::Util
::which
(@
{$_[2]}->[0]);
return '' unless $script;
# let's see if it really looks like a perl script
if (open(FILE
,"< $script")) {
if (($filename,$switches) =
($firstline =~ m
|^\#
!\s
*(/.*perl
)(\s
+.+)?
$|go
)
and matches_perl_binary
($filename)) {
my $possibleMatch = $script;
my %bangLineOptions = ();
local @ARGV = split(' ', $switches);
# All perl command-line options that take aruments as of
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");
my ($script, @options) = split(' ',$_[3]);
shift @arglist; # Get rid of script name
if (scalar(@arglist) > 0) {
my $lastarg = pop @arglist;
if ($lastarg =~ m/\&$/) {
if ($lastarg) { push @arglist, $lastarg; }
print_debug
("[[perlscript $script, options @options, args @arglist.]]\n");
foreach (@options) { $opts{$_} = 1; }
# 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?
if ($opts{warnings
}) { $^W
= 1; }
local $Psh::tmp
= do $script;