Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Psh::Strategy::Perlscript; |
2 | ||
3 | require Psh::Strategy; | |
4 | require Psh::Util; | |
5 | ||
6 | =item * C<perlscript> | |
7 | ||
8 | If (1) the first word of the input line matches the | |
9 | name of a file found in one of the directories listed | |
10 | in the path ($ENV{PATH}), and (2) that file starts | |
11 | with #!/.../perl, and (3) that perl is the same as the | |
12 | Perl under which psh is running, psh will fork and run | |
13 | the script using the already-loaded Perl interpreter. | |
14 | The idea is to save the exec half of the fork-exec | |
15 | that the executable strategy would do; typically the | |
16 | exec is more expensive. Right now this strategy can | |
17 | only handle the -w command-line switch on the #! line. | |
18 | Note this strategy only makes sense before the | |
19 | "executable" strategy; if it came after, it could | |
20 | never trigger. | |
21 | ||
22 | =cut | |
23 | ||
24 | @Psh::Strategy::Perlscript::ISA=('Psh::Strategy'); | |
25 | ||
26 | sub new { Psh::Strategy::new(@_) } | |
27 | ||
28 | sub consumes { | |
29 | return Psh::Strategy::CONSUME_TOKENS; | |
30 | } | |
31 | ||
32 | sub runs_before { | |
33 | return qw(executable); | |
34 | } | |
35 | ||
36 | # | |
37 | # bool matches_perl_binary(string FILENAME) | |
38 | # | |
39 | # Returns true if FILENAME referes directly or indirectly to the | |
40 | # current perl executable | |
41 | # | |
42 | ||
43 | sub matches_perl_binary | |
44 | { | |
45 | my ($filename) = @_; | |
46 | require Config; | |
47 | ||
48 | # | |
49 | # Chase down symbolic links, but don't crash on systems that don't | |
50 | # have them: | |
51 | # | |
52 | ||
53 | if ($Config::Config{d_readlink}) { | |
54 | my $newfile; | |
55 | while ($newfile = readlink($filename)) { $filename = $newfile; } | |
56 | } | |
57 | ||
58 | if ($filename eq $Config::Config{perlpath}) { return 1; } | |
59 | ||
60 | my ($perldev,$perlino) = (stat($Config::Config{perlpath}))[0,1]; | |
61 | my ($dev,$ino) = (stat($filename))[0,1]; | |
62 | ||
63 | # | |
64 | # TODO: Does the following work on non-Unix OS ? | |
65 | # | |
66 | ||
67 | if ($perldev == $dev and $perlino == $ino) { return 1; } | |
68 | ||
69 | return 0; | |
70 | } | |
71 | ||
72 | sub applies { | |
73 | my $script = Psh::Util::which(@{$_[2]}->[0]); | |
74 | return '' unless $script; | |
75 | ||
76 | # | |
77 | # let's see if it really looks like a perl script | |
78 | # | |
79 | my $firstline; | |
80 | if (open(FILE,"< $script")) { | |
81 | $firstline= <FILE>; | |
82 | close(FILE); | |
83 | } | |
84 | else { | |
85 | return; | |
86 | } | |
87 | chomp $firstline; | |
88 | ||
89 | my $filename; | |
90 | my $switches; | |
91 | ||
92 | if (($filename,$switches) = | |
93 | ($firstline =~ m|^\#!\s*(/.*perl)(\s+.+)?$|go) | |
94 | and matches_perl_binary($filename)) { | |
95 | my $possibleMatch = $script; | |
96 | my %bangLineOptions = (); | |
97 | ||
98 | if( $switches) { | |
99 | $switches=~ s/^\s+//go; | |
100 | local @ARGV = split(' ', $switches); | |
101 | ||
102 | # | |
103 | # All perl command-line options that take aruments as of | |
104 | # Perl 5.00503: | |
105 | # | |
106 | ||
107 | require Getopt::Std; | |
108 | getopt('DeiFlimMx', \%bangLineOptions); | |
109 | } | |
110 | ||
111 | if ($bangLineOptions{w}) { | |
112 | $possibleMatch .= " warnings"; | |
113 | delete $bangLineOptions{w}; | |
114 | } | |
115 | ||
116 | # | |
117 | # TODO: We could handle more options. [There are some we | |
118 | # can't. -d, -n and -p are popular ones that would be tough.] | |
119 | # | |
120 | ||
121 | if (scalar(keys %bangLineOptions) > 0) { | |
122 | print_debug("[[perlscript: skip $script, options $switches.]]\n"); | |
123 | return ''; | |
124 | } | |
125 | return $possibleMatch; | |
126 | } | |
127 | return ''; | |
128 | } | |
129 | ||
130 | ||
131 | sub execute { | |
132 | my ($script, @options) = split(' ',$_[3]); | |
133 | my @arglist = @{$_[2]}; | |
134 | ||
135 | shift @arglist; # Get rid of script name | |
136 | my $fgflag = 1; | |
137 | ||
138 | if (scalar(@arglist) > 0) { | |
139 | my $lastarg = pop @arglist; | |
140 | ||
141 | if ($lastarg =~ m/\&$/) { | |
142 | $fgflag = 0; | |
143 | $lastarg =~ s/\&$//; | |
144 | } | |
145 | ||
146 | if ($lastarg) { push @arglist, $lastarg; } | |
147 | } | |
148 | ||
149 | print_debug("[[perlscript $script, options @options, args @arglist.]]\n"); | |
150 | ||
151 | my $pid; | |
152 | ||
153 | my %opts = (); | |
154 | foreach (@options) { $opts{$_} = 1; } | |
155 | ||
156 | ||
157 | return (1,sub { | |
158 | package main; | |
159 | # TODO: Is it possible/desirable to put main in the pristine | |
160 | # state that it typically is in when a script starts up, | |
161 | # i.e. undefine all routines and variables that the user has set? | |
162 | local @ARGV = @arglist; | |
163 | local $^W; | |
164 | ||
165 | if ($opts{warnings}) { $^W = 1; } | |
166 | else { $^W = 0; } | |
167 | ||
168 | local $Psh::tmp= do $script; | |
169 | ||
170 | CORE::exit !$Psh::tmp; | |
171 | }, [], 1, undef); | |
172 | } | |
173 | ||
174 | 1; |