line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Run; |
2
|
|
|
|
|
|
|
|
3
|
9
|
|
|
9
|
|
17817
|
use strict; |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
358
|
|
4
|
9
|
|
|
9
|
|
39
|
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
|
9
|
|
|
|
|
16
|
|
|
9
|
|
|
|
|
53826
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
require Exporter; |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
# This is voodoo, but with these settings test works: |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my $no_error_on_unwind_close = 1; |
11
|
|
|
|
|
|
|
my $use_longer_control_F = 0; # redir.t no. 13 is fragile with this |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
@ISA = qw(Exporter); |
14
|
|
|
|
|
|
|
# Items to export into callers namespace by default. Note: do not export |
15
|
|
|
|
|
|
|
# names by default without a very good reason. Use EXPORT_OK instead. |
16
|
|
|
|
|
|
|
# Do not simply export all your public functions/methods/constants. |
17
|
|
|
|
|
|
|
@EXPORT = qw( |
18
|
|
|
|
|
|
|
spawn |
19
|
|
|
|
|
|
|
); |
20
|
|
|
|
|
|
|
$VERSION = '0.03'; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
%EXPORT_TAGS = ( NEW => [qw(new_system new_spawn new_or new_and new_chain |
23
|
|
|
|
|
|
|
new_env new_redir new_pipe new_readpipe |
24
|
|
|
|
|
|
|
new_readpipe_split)] ); |
25
|
|
|
|
|
|
|
@EXPORT_OK = @{$EXPORT_TAGS{NEW}}; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
@Run::and::ISA = @Run::or::ISA = @Run::chain::ISA = @Run::spawn::ISA |
28
|
|
|
|
|
|
|
= @Run::system::ISA = qw(Run::base); |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
@Run::env::ISA = @Run::pipe::ISA = @Run::redir::ISA = qw(Run::base2); |
31
|
|
|
|
|
|
|
@Run::readpipe::ISA = @Run::readpipe_split::ISA = qw(Run::base1); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
my $Debug = $ENV{PERL_RUN_DEBUG} && fileno STDERR; |
34
|
|
|
|
|
|
|
my $SaveErr; |
35
|
|
|
|
|
|
|
if ($Debug) { |
36
|
|
|
|
|
|
|
if ($Debug > 1) { |
37
|
|
|
|
|
|
|
$SaveErr = \*SAVERR; |
38
|
|
|
|
|
|
|
open $SaveErr, ">&STDERR" or die "Cannot dup STDERR: $!"; |
39
|
|
|
|
|
|
|
require IO::Handle; |
40
|
|
|
|
|
|
|
bless $SaveErr, 'IO::Handle'; |
41
|
|
|
|
|
|
|
$SaveErr->autoflush(1); |
42
|
|
|
|
|
|
|
} else { |
43
|
|
|
|
|
|
|
$SaveErr = \*STDERR; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub spawn { |
48
|
20
|
50
|
33
|
20
|
0
|
821
|
if ($^O eq 'os2') { |
|
|
50
|
|
|
|
|
|
49
|
0
|
0
|
0
|
|
|
0
|
if (@_ == 1 and ( $_[0] =~ /[\`|\"\'\$&;*?\{\}\[\]\(\)<>\s~]/ |
|
|
|
0
|
|
|
|
|
50
|
|
|
|
|
|
|
# backslashes are allowed as far as |
51
|
|
|
|
|
|
|
# there is no whitespace. |
52
|
|
|
|
|
|
|
or $_[0] =~ /^\s*\w+=/ )) { |
53
|
|
|
|
|
|
|
# system 1, blah would not use shell |
54
|
0
|
|
|
|
|
0
|
unshift @_, '/bin/sh', '-c'; # /bin/sh will be auto-translated |
55
|
|
|
|
|
|
|
# to the installed place by system(). |
56
|
|
|
|
|
|
|
} |
57
|
0
|
|
|
|
|
0
|
return system 1, @_; |
58
|
|
|
|
|
|
|
} elsif ($^O eq 'MSWin32' or $^O eq 'VMS') { |
59
|
0
|
|
|
|
|
0
|
return system 1, @_; |
60
|
|
|
|
|
|
|
} else { |
61
|
20
|
50
|
|
|
|
243
|
print $SaveErr "forking...\t\t\t\t\t\t\t\$^F=$^F\n" if $Debug; |
62
|
20
|
|
|
|
|
25681
|
my $pid = fork; |
63
|
20
|
50
|
|
|
|
1213
|
return unless defined $pid; |
64
|
20
|
100
|
|
|
|
1297
|
return $pid if $pid; # parent |
65
|
|
|
|
|
|
|
# kid: |
66
|
5
|
50
|
|
|
|
752
|
print $SaveErr "execing `@_'...\n" if $Debug; |
67
|
5
|
0
|
|
|
|
0
|
exec @_ or die "exec '@_': $!"; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub xfcntl ($$$$;$) { |
72
|
42
|
|
|
42
|
0
|
101
|
my ($fh, $mode, $flag, $errs, $how) = @_; |
73
|
42
|
50
|
|
|
|
360
|
my $fd = ref $fh ? fileno $fh : $fh; |
74
|
42
|
|
50
|
|
|
845
|
$how ||= ""; |
75
|
42
|
|
|
|
|
179
|
my $str_mode = ''; |
76
|
42
|
0
|
|
|
|
106
|
$str_mode = ($mode == Fcntl::F_GETFD() |
|
|
0
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
77
|
|
|
|
|
|
|
? '=get' |
78
|
|
|
|
|
|
|
: ($mode == Fcntl::F_SETFD() |
79
|
|
|
|
|
|
|
? '=set' |
80
|
|
|
|
|
|
|
: '=???')) if $Debug; |
81
|
|
|
|
|
|
|
|
82
|
42
|
50
|
0
|
|
|
246
|
my $ret = fcntl($fh, $mode, $flag) |
83
|
|
|
|
|
|
|
or push @$errs, "$ {how}fcntl get $fd: $!", |
84
|
|
|
|
|
|
|
($Debug and print $SaveErr $errs->[-1], "\n"), |
85
|
|
|
|
|
|
|
return; |
86
|
42
|
50
|
|
|
|
105
|
print $SaveErr "$ {how}fcntl($fd, $mode$str_mode, $flag) => $ret\n" |
87
|
|
|
|
|
|
|
if $Debug; |
88
|
42
|
|
|
|
|
147
|
$ret; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub xclose ($$$) { |
92
|
32
|
|
|
32
|
0
|
95
|
my ($fh, $errs, $how) = @_; |
93
|
32
|
|
|
|
|
86
|
my $fd = fileno $fh; |
94
|
|
|
|
|
|
|
|
95
|
32
|
50
|
|
|
|
192
|
print $SaveErr "$ {how}closing fd=$fd...\n" if $Debug; |
96
|
32
|
|
|
|
|
376
|
my $res = close($fh); |
97
|
32
|
50
|
33
|
|
|
112
|
print "$ {how}close $fh fd=$fd => `$res': $!\n" |
98
|
|
|
|
|
|
|
if not $res and $Debug; |
99
|
32
|
50
|
0
|
|
|
113
|
if ($res or $no_error_on_unwind_close and $how eq "unwind: ") { |
|
|
|
33
|
|
|
|
|
100
|
32
|
|
|
|
|
160
|
return $res; |
101
|
|
|
|
|
|
|
} |
102
|
0
|
|
|
|
|
0
|
push(@$errs, "$ {how}close $fh fd=$fd: $!"); |
103
|
0
|
|
|
|
|
0
|
return; |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub xfdopen ($$$$$) { |
107
|
39
|
|
|
39
|
0
|
747
|
my ($fh1, $fh2, $mode, $errs, $how) = @_; |
108
|
39
|
|
|
|
|
1320
|
my $fd1 = fileno $fh1; |
109
|
39
|
100
|
|
|
|
391
|
my $fd2 = ref $fh2 ? fileno $fh2 : $fh2; |
110
|
39
|
|
|
|
|
47
|
my $res; |
111
|
39
|
100
|
|
|
|
210
|
my $omode = ($mode eq 'r' ? '<' : '>'); |
112
|
|
|
|
|
|
|
|
113
|
39
|
50
|
|
|
|
100
|
print $SaveErr "$ {how}open( fd=$fd1, '$omode&$fd2')\n" if $Debug; |
114
|
|
|
|
|
|
|
|
115
|
39
|
50
|
|
|
|
1571
|
if ($res = open($fh1,"$omode&$fd2")) { |
116
|
39
|
50
|
|
|
|
100
|
print $SaveErr " -> ", fileno $fh1, "\t\t\t\t$res\t\$^F=$^F\n" if $Debug; |
117
|
39
|
|
|
|
|
194
|
return $res; |
118
|
|
|
|
|
|
|
} else { |
119
|
0
|
|
0
|
|
|
0
|
push(@$errs, "$ {how}open( fd=$fd1, '$omode&$fd2'): $!"), |
120
|
|
|
|
|
|
|
($Debug and print $SaveErr $errs->[-1], "\n"), |
121
|
|
|
|
|
|
|
return; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
} |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub xnew_from_fd ($$$$) { # Give up soon |
126
|
24
|
|
|
24
|
0
|
64
|
my ($fh, $mode, $errs, $how) = @_; |
127
|
24
|
100
|
|
|
|
254
|
my $fd = ref $fh ? fileno $fh : $fh; |
128
|
24
|
100
|
|
|
|
115
|
my $fd_printable = ref $fh ? "fh=>" . fileno $fh : $fh; |
129
|
|
|
|
|
|
|
|
130
|
24
|
50
|
|
|
|
76
|
print $SaveErr "$ {how}new_from_fd($fd_printable, $mode)\n" if $Debug; |
131
|
24
|
|
|
|
|
164
|
my $res = IO::Handle->new_from_fd($fh, $mode); |
132
|
24
|
100
|
|
|
|
3649
|
if ($res) { |
133
|
22
|
50
|
|
|
|
59
|
print $SaveErr " -> ", fileno $res, "\t\t\t\t$res\t\$^F=$^F\n" if $Debug; |
134
|
22
|
|
|
|
|
117
|
return $res; |
135
|
|
|
|
|
|
|
} |
136
|
2
|
|
|
|
|
78
|
push @$errs, "$ {how}new_from_fd($fd_printable, $mode): $!"; |
137
|
2
|
50
|
|
|
|
10
|
print $SaveErr $errs->[-1], "\n" if $Debug; |
138
|
2
|
|
|
|
|
560
|
return; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
# if we need to close_in_keed and need_in_parent, we need unwinding of fcntl |
142
|
|
|
|
|
|
|
# |
143
|
|
|
|
|
|
|
# returns undef on failure |
144
|
|
|
|
|
|
|
# |
145
|
|
|
|
|
|
|
# list to close may be too big, exclude fds which are going to be redirected |
146
|
|
|
|
|
|
|
# |
147
|
|
|
|
|
|
|
# Note that this is probably excessive, $^F handles this in simplest cases |
148
|
|
|
|
|
|
|
# |
149
|
|
|
|
|
|
|
# Need to maintain a list of all open fd, and give it to this guy |
150
|
|
|
|
|
|
|
sub process_close_in_kid { |
151
|
|
|
|
|
|
|
# Stderr may be redirected, so we save the err text in @$errs: |
152
|
42
|
|
|
42
|
0
|
114
|
my ($close_in_child, $unwind, $redirected, $errs) = @_; |
153
|
42
|
50
|
|
|
|
150
|
return unless @$close_in_child; |
154
|
42
|
|
|
|
|
246
|
require Fcntl; |
155
|
42
|
|
|
|
|
101
|
my $fd; |
156
|
|
|
|
|
|
|
|
157
|
42
|
|
|
|
|
113
|
foreach $fd (@$close_in_child) { |
158
|
42
|
50
|
|
|
|
204
|
next if $redirected->{$fd}; # Do not close what we redirect! |
159
|
42
|
50
|
|
|
|
246
|
my $fl = xfcntl($fd, Fcntl::F_GETFD(), 1, $errs) or return; |
160
|
42
|
50
|
|
|
|
537
|
next if $fl & Fcntl::FD_CLOEXEC(); |
161
|
0
|
0
|
|
|
|
0
|
xfcntl($fd, Fcntl::F_SETFD(), $fl | Fcntl::FD_CLOEXEC(), $errs) |
162
|
|
|
|
|
|
|
or return; |
163
|
0
|
|
|
|
|
0
|
push @$unwind, ["fset", $fd, $fl]; |
164
|
|
|
|
|
|
|
} |
165
|
42
|
|
|
|
|
142
|
return 1; |
166
|
|
|
|
|
|
|
} |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
# returns undef on failure |
169
|
|
|
|
|
|
|
sub do_unwind { |
170
|
19
|
|
|
19
|
0
|
67
|
my ($unwind, $errs) = @_; |
171
|
19
|
|
|
|
|
55
|
my $cmd; |
172
|
19
|
|
|
|
|
78
|
my $res = 1; |
173
|
|
|
|
|
|
|
|
174
|
19
|
|
|
|
|
94
|
while (@$unwind) { |
175
|
34
|
|
|
|
|
273
|
$cmd = pop @$unwind; |
176
|
34
|
50
|
|
|
|
649
|
if ($cmd->[0] eq 'fset') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
177
|
0
|
0
|
|
|
|
0
|
xfcntl($cmd->[1], Fcntl::F_SETFD(), $cmd->[2], $errs, "unwind: ") |
178
|
|
|
|
|
|
|
or undef $res; # Continue on error |
179
|
|
|
|
|
|
|
} elsif ($cmd->[0] eq 'close') { |
180
|
17
|
50
|
|
|
|
125
|
xclose($cmd->[1], $errs, "unwind: ") |
181
|
|
|
|
|
|
|
or undef $res; # Continue on error |
182
|
|
|
|
|
|
|
} elsif ($cmd->[0] eq 'fdopen') { |
183
|
17
|
50
|
|
|
|
314
|
xfdopen($cmd->[1], $cmd->[2], $cmd->[3], $errs, "unwind: ") |
184
|
|
|
|
|
|
|
or undef $res; # Continue on error |
185
|
|
|
|
|
|
|
} else { |
186
|
0
|
|
|
|
|
0
|
push(@$errs, "unwind: unknown cmd `@$cmd'"); |
187
|
0
|
0
|
|
|
|
0
|
print $SaveErr $errs->[-1], "\n" if $Debug; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
} |
190
|
19
|
|
|
|
|
166
|
return $res; |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
sub cvt_2filehandle { |
194
|
49
|
|
|
49
|
0
|
86
|
my ($fds, $unwind, $errs) = @_; |
195
|
49
|
|
|
|
|
58
|
my ($fd, $fd_data); |
196
|
|
|
|
|
|
|
# Convert filename => filehandle. |
197
|
49
|
|
|
|
|
192
|
for $fd (keys %$fds) { |
198
|
50
|
|
|
|
|
86
|
$fd_data = $fds->{$fd}; |
199
|
|
|
|
|
|
|
|
200
|
50
|
|
|
|
|
92
|
my $file = delete $fd_data->{filename}; |
201
|
50
|
50
|
|
|
|
272
|
if ($file) { |
202
|
0
|
|
|
|
|
0
|
require IO::File; |
203
|
0
|
|
|
|
|
0
|
my $fh; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# Will open a wrong guy, there should be a different way to do this... |
206
|
0
|
|
|
|
|
0
|
if (0 and $file =~ /^\s*([<>])\s*&\s*=\s*(.*)/s) { |
207
|
|
|
|
|
|
|
my $fd = $2; |
208
|
|
|
|
|
|
|
my $mode = $1 eq '<' ? "r" : "w"; |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
$fd = fileno $fd unless $fd =~ /^\d+\s*$/; |
211
|
|
|
|
|
|
|
$fh = fd_2filehandle($fd, $mode, $fds, $unwind, $errs) or return; |
212
|
|
|
|
|
|
|
} else { |
213
|
0
|
0
|
|
|
|
0
|
print $SaveErr "open `$file'\n" if $Debug; |
214
|
0
|
0
|
0
|
|
|
0
|
$fh = new IO::File $file |
215
|
|
|
|
|
|
|
or (push @$errs, "Cannot open `$file': $!"), |
216
|
|
|
|
|
|
|
($Debug and print $SaveErr $errs->[-1], "\n"), |
217
|
|
|
|
|
|
|
return; |
218
|
0
|
0
|
|
|
|
0
|
print $SaveErr " --> ", fileno $fh, "\t\t\t\t$fh\t\$^F=$^F\n" if $Debug; |
219
|
0
|
|
|
|
|
0
|
push @$unwind, ["close", $fh]; # Will be done automagically when |
220
|
|
|
|
|
|
|
# goes out of scope, but would |
221
|
|
|
|
|
|
|
# not hurt to do earlier |
222
|
|
|
|
|
|
|
} |
223
|
0
|
|
|
|
|
0
|
$fd_data->{filehandle} = $fh; |
224
|
0
|
0
|
|
|
|
0
|
$fd_data->{mode} = ($file =~ /^\s*(\+\s*)?[>|]/ ? 'w' : 'r'); |
225
|
0
|
|
|
|
|
0
|
$fd_data->{kid_only} = 0; # :-( Might redirect several kids to it |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
} |
228
|
49
|
|
|
|
|
180
|
return 1; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# Need to keep filehandles globally, since closing a clone close |
232
|
|
|
|
|
|
|
# the original |
233
|
|
|
|
|
|
|
my %fd_hash = ( 0 => \*STDIN, 1 => \*STDOUT, 2 => \*STDERR); |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# $old is any filehandle which is going to live long enough. |
236
|
|
|
|
|
|
|
sub fd_2filehandle ($$$$$) { |
237
|
25
|
|
|
25
|
0
|
66
|
my ($fd,$mode,$fds,$unwind,$errs) = @_; |
238
|
25
|
|
|
|
|
127
|
require Fcntl; |
239
|
25
|
50
|
100
|
|
|
2180
|
if (exists $fd_hash{$fd} and defined fileno($fd_hash{$fd}) |
|
|
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
240
|
|
|
|
|
|
|
and fileno($fd_hash{$fd}) == $fd |
241
|
|
|
|
|
|
|
and fcntl($fd_hash{$fd}, Fcntl::F_GETFD(), 1)) { # Checking that it is not closed! |
242
|
22
|
|
|
|
|
116
|
require IO::Handle; |
243
|
22
|
100
|
|
|
|
121
|
bless $fd_hash{$fd}, 'IO::Handle' if ref $fd_hash{$fd} eq 'GLOB'; |
244
|
22
|
50
|
|
|
|
78
|
print $SaveErr "filehandle $fd stashed...\n" if $Debug; |
245
|
22
|
|
|
|
|
108
|
return $fd_hash{$fd}; # In fact the corresponding FD may be |
246
|
|
|
|
|
|
|
# closed, but there is nothing to do |
247
|
|
|
|
|
|
|
# about it... |
248
|
|
|
|
|
|
|
} |
249
|
2
|
|
|
|
|
6
|
delete $fd_hash{$fd}; |
250
|
|
|
|
|
|
|
# Grab the file descriptor |
251
|
2
|
|
|
|
|
23
|
my $fh = xnew_from_fd($fd, $mode, [], "grabfd: "); # ignore errors |
252
|
2
|
50
|
33
|
|
|
42
|
if (not defined $fh and $! =~ /bad\s+file\s+number/i) { |
253
|
0
|
0
|
|
|
|
0
|
print $SaveErr "Recovering from error in new_from_fd...\n" if $Debug; |
254
|
|
|
|
|
|
|
# Try to create missing filehandles |
255
|
0
|
|
|
|
|
0
|
my ($cnt, @tmp, $tmp_fh, $ok) = 0; |
256
|
0
|
|
|
|
|
0
|
my $old = $fds->{$fd}{filehandle}; |
257
|
|
|
|
|
|
|
|
258
|
0
|
|
|
|
|
0
|
while ($cnt++ <= $fd) { # Give up soon |
259
|
0
|
0
|
|
|
|
0
|
$tmp_fh = xnew_from_fd($old, $mode, $errs, "intermed fd: ") or return; |
260
|
0
|
0
|
|
|
|
0
|
$ok = 1, last if fileno $tmp_fh == $fd; |
261
|
0
|
|
|
|
|
0
|
push @tmp, $tmp_fh; |
262
|
|
|
|
|
|
|
} |
263
|
0
|
0
|
|
|
|
0
|
unless ($ok) { |
264
|
0
|
|
|
|
|
0
|
push @$errs, "Could not create fd=$fd"; |
265
|
0
|
0
|
|
|
|
0
|
print $SaveErr $errs->[-1], "\n" if $Debug; |
266
|
0
|
|
|
|
|
0
|
return; |
267
|
|
|
|
|
|
|
} |
268
|
0
|
0
|
|
|
|
0
|
$fds->{$fd}{tmp_filehandles} = [] |
269
|
|
|
|
|
|
|
unless defined $fds->{$fd}{tmp_filehandles}; |
270
|
0
|
|
|
|
|
0
|
push @{$fds->{$fd}{tmp_filehandles}}, @tmp; # Do not close these guys soon |
|
0
|
|
|
|
|
0
|
|
271
|
0
|
|
|
|
|
0
|
$fh = $tmp_fh; |
272
|
0
|
0
|
|
|
|
0
|
process_close_in_kid(\@tmp, $unwind, $fds, $errs) or return; |
273
|
|
|
|
|
|
|
} |
274
|
2
|
|
|
|
|
615
|
return $fd_hash{$fd} = $fh; # never close this |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub redirect_in_kid { |
278
|
25
|
|
|
25
|
0
|
79
|
my ($fds,$unwind,$errs,$max_fd_r) = @_; |
279
|
25
|
|
|
|
|
35
|
my ($fd_data, $fd); |
280
|
25
|
|
|
|
|
43
|
my $max_fd = -1; |
281
|
|
|
|
|
|
|
# Count |
282
|
25
|
|
|
|
|
100
|
for $fd (keys %$fds) { |
283
|
26
|
50
|
|
|
|
219
|
$max_fd = $fd if $fd > $max_fd; |
284
|
|
|
|
|
|
|
} |
285
|
25
|
50
|
|
|
|
88
|
return 1 unless $max_fd > -1; |
286
|
|
|
|
|
|
|
|
287
|
25
|
50
|
|
|
|
64
|
cvt_2filehandle($fds,$unwind,$errs) or return; |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
# The guys below this level will be dup2()ed to on fdopen(). |
290
|
|
|
|
|
|
|
# They also will not be closed on exec |
291
|
25
|
100
|
|
|
|
154
|
local $^F = $$max_fd_r = $max_fd if $max_fd > $^F; |
292
|
|
|
|
|
|
|
|
293
|
25
|
|
|
|
|
36
|
my @close_in_child; |
294
|
25
|
|
|
|
|
2554
|
require IO::Handle; |
295
|
25
|
|
|
|
|
29387
|
for $fd (keys %$fds) { |
296
|
25
|
|
|
|
|
39
|
$fd_data = $fds->{$fd}; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# Grab the file descriptor |
299
|
25
|
100
|
|
|
|
125
|
$fd_data->{pre_filehandle} = |
300
|
|
|
|
|
|
|
fd_2filehandle($fd, $fd_data->{mode}, $fds, $unwind, $errs) |
301
|
|
|
|
|
|
|
or return; |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# Now save a copy to another filedescriptor |
304
|
22
|
50
|
|
|
|
98
|
$fd_data->{pre_filehandle_save} |
305
|
|
|
|
|
|
|
= xnew_from_fd($fd_data->{pre_filehandle}, $fd_data->{mode}, $errs, "savecopy: ") |
306
|
|
|
|
|
|
|
or return; |
307
|
22
|
|
|
|
|
79
|
push @$unwind, ["close", $fd_data->{pre_filehandle_save}]; |
308
|
22
|
|
|
|
|
51
|
push @close_in_child, $fd_data->{pre_filehandle_save}; |
309
|
|
|
|
|
|
|
|
310
|
22
|
50
|
|
|
|
118
|
xfdopen($fd_data->{pre_filehandle}, fileno $fd_data->{filehandle}, |
311
|
|
|
|
|
|
|
$fd_data->{mode}, $errs, "final: ") |
312
|
|
|
|
|
|
|
or return; |
313
|
22
|
|
|
|
|
124
|
push @$unwind, |
314
|
|
|
|
|
|
|
["fdopen", $fd_data->{pre_filehandle}, $fd_data->{pre_filehandle_save}, |
315
|
|
|
|
|
|
|
$fd_data->{mode}]; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Arrange for things to be closed in the kid: |
319
|
22
|
50
|
|
|
|
81
|
process_close_in_kid(\@close_in_child, $unwind, $fds, $errs) |
320
|
|
|
|
|
|
|
or return; |
321
|
22
|
|
|
|
|
71
|
return 1; |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
sub run_system_spawn { |
325
|
46
|
|
|
46
|
0
|
95
|
my $do_spawn = shift; |
326
|
46
|
100
|
|
|
|
371
|
$_[1] = {} unless defined $_[1]; |
327
|
46
|
|
|
|
|
93
|
my ($tree, $data) = @_; |
328
|
|
|
|
|
|
|
# Sets result in $data->{result} on failure |
329
|
6
|
|
|
|
|
42
|
(local %::ENV = %::ENV), |
330
|
46
|
100
|
|
|
|
860
|
@::ENV{keys %{$data->{env}}} = values %{$data->{env}} |
|
6
|
|
|
|
|
32
|
|
331
|
|
|
|
|
|
|
if (exists $data->{env}); |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# Expand args: |
334
|
46
|
100
|
|
|
|
488
|
my @args = map {ref $_ ? $_->run : ($_)} @$tree; |
|
140
|
|
|
|
|
538
|
|
335
|
45
|
|
|
|
|
126
|
my $has_undef = grep {not defined} @args; |
|
138
|
|
|
|
|
418
|
|
336
|
45
|
50
|
|
|
|
181
|
return if $has_undef; |
337
|
|
|
|
|
|
|
|
338
|
45
|
|
|
|
|
100
|
my $unwind = []; |
339
|
45
|
|
|
|
|
106
|
my $max_fd; |
340
|
45
|
|
|
|
|
4005
|
my $print_errs = not exists $data->{errs}; |
341
|
45
|
100
|
|
|
|
235
|
my $errs = $print_errs ? [] : $data->{errs}; |
342
|
|
|
|
|
|
|
|
343
|
45
|
100
|
|
|
|
175
|
if (defined $data->{redir}) { # local could create undefined value |
344
|
25
|
|
|
|
|
110
|
my $res = redirect_in_kid($data->{redir},$unwind,$errs,\$max_fd); |
345
|
24
|
100
|
|
|
|
83
|
if (not $res) { |
346
|
2
|
50
|
33
|
|
|
37
|
local $^F = $max_fd |
|
|
|
33
|
|
|
|
|
347
|
|
|
|
|
|
|
if defined $max_fd and $max_fd > $^F and $use_longer_control_F; |
348
|
2
|
|
|
|
|
8
|
do_unwind($unwind,$errs); |
349
|
|
|
|
|
|
|
# Should hope that STDERR is now restored |
350
|
2
|
50
|
33
|
|
|
23
|
print STDERR join "\n", @$errs, "" if $print_errs and @$errs; |
351
|
2
|
|
|
|
|
11
|
return; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
} |
354
|
42
|
0
|
33
|
|
|
145
|
local $^F = $max_fd |
|
|
|
33
|
|
|
|
|
355
|
|
|
|
|
|
|
if defined $max_fd and $max_fd > $^F and $use_longer_control_F; |
356
|
|
|
|
|
|
|
|
357
|
42
|
|
|
|
|
60
|
my $res; |
358
|
42
|
100
|
66
|
|
|
457
|
if ($do_spawn or $data->{'spawn'}) { |
359
|
20
|
|
|
|
|
71
|
$res = spawn @args; |
360
|
15
|
50
|
|
|
|
419
|
push @{$data->{pids}}, $res if defined $res; |
|
15
|
|
|
|
|
597
|
|
361
|
15
|
50
|
|
|
|
88
|
push @$errs, "spawn `@args': $!" unless defined $res; |
362
|
|
|
|
|
|
|
} else { |
363
|
22
|
|
|
|
|
220968
|
$res = system @args; |
364
|
22
|
100
|
|
|
|
829
|
$data->{result} = $res if $res; |
365
|
22
|
100
|
|
|
|
415
|
push @$errs, "system `@args': rc=$res: $!" if $res; # XXXX? |
366
|
22
|
100
|
|
|
|
288
|
$res = ($res == 0 ? 1 : undef); |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
|
369
|
37
|
100
|
|
|
|
866
|
do_unwind($unwind,$errs) if @$unwind; |
370
|
|
|
|
|
|
|
# Should hope that STDERR is now restored |
371
|
37
|
50
|
66
|
|
|
673
|
print STDERR join "\n", @$errs, "" if $print_errs and @$errs; |
372
|
37
|
|
|
|
|
2751
|
return $res; |
373
|
|
|
|
|
|
|
} |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
sub Run::system::run { |
376
|
46
|
|
|
46
|
|
252
|
run_system_spawn(0,@_); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
sub Run::spawn::run { |
380
|
0
|
|
|
0
|
|
0
|
run_system_spawn(1,@_); |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub Run::chain::run { |
385
|
3
|
100
|
|
3
|
|
16
|
$_[1] = {} unless defined $_[1]; |
386
|
3
|
|
|
|
|
6
|
my ($tree, $data) = @_; |
387
|
3
|
|
|
|
|
9
|
my $out = 1; |
388
|
|
|
|
|
|
|
|
389
|
3
|
50
|
|
|
|
15
|
print(STDERR "cannot 'chain' with spawn: $!\n"), return if $data->{'spawn'}; |
390
|
3
|
|
|
|
|
23
|
for my $cmd (@$tree) { |
391
|
6
|
|
|
|
|
61
|
my $res = $cmd->run($data); |
392
|
6
|
50
|
|
|
|
117
|
undef $out unless defined $res; |
393
|
|
|
|
|
|
|
} |
394
|
3
|
|
|
|
|
70
|
return $out; |
395
|
|
|
|
|
|
|
} |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub Run::and::run { |
398
|
3
|
100
|
|
3
|
|
104
|
$_[1] = {} unless defined $_[1]; |
399
|
3
|
|
|
|
|
8
|
my ($tree, $data) = @_; |
400
|
|
|
|
|
|
|
|
401
|
3
|
50
|
|
|
|
13
|
print(STDERR "cannot 'and' with spawn: $!\n"), return if $data->{'spawn'}; |
402
|
3
|
|
|
|
|
19
|
for my $cmd (@$tree) { |
403
|
5
|
|
|
|
|
79
|
my $res = $cmd->run($data); |
404
|
5
|
100
|
|
|
|
113
|
return unless defined $res; |
405
|
|
|
|
|
|
|
} |
406
|
1
|
|
|
|
|
40
|
return 1; |
407
|
|
|
|
|
|
|
} |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
sub Run::or::run { |
410
|
3
|
100
|
|
3
|
|
37
|
$_[1] = {} unless defined $_[1]; |
411
|
3
|
|
|
|
|
7
|
my ($tree, $data) = @_; |
412
|
|
|
|
|
|
|
|
413
|
3
|
50
|
|
|
|
18
|
print(STDERR "cannot 'or' with spawn: $!\n"), return if $data->{'spawn'}; |
414
|
3
|
|
|
|
|
25
|
for my $cmd (@$tree) { |
415
|
5
|
|
|
|
|
57
|
my $res = $cmd->run($data); |
416
|
5
|
100
|
|
|
|
210
|
return 1 if defined $res; |
417
|
|
|
|
|
|
|
} |
418
|
1
|
|
|
|
|
41
|
return; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
sub Run::env::run { |
422
|
4
|
100
|
|
4
|
|
30
|
$_[1] = {} unless defined $_[1]; |
423
|
4
|
|
|
|
|
10
|
my ($tree, $data) = @_; |
424
|
4
|
|
|
|
|
72
|
my $cmd = $tree->[1]; |
425
|
4
|
|
|
|
|
30
|
local $data->{env} = $data->{env}; |
426
|
4
|
100
|
|
|
|
28
|
$data->{env} = {} unless defined $data->{env}; |
427
|
4
|
|
|
|
|
14
|
my %env = %{$data->{env}}; |
|
4
|
|
|
|
|
37
|
|
428
|
4
|
|
|
|
|
18
|
my $env = $tree->[0]; |
429
|
4
|
|
|
|
|
14
|
@{$data->{env}}{keys %$env} = values %$env; |
|
4
|
|
|
|
|
19
|
|
430
|
|
|
|
|
|
|
|
431
|
4
|
|
|
|
|
35
|
my $res = $cmd->run($data); |
432
|
4
|
|
|
|
|
43
|
%{$data->{env}} = %env; |
|
4
|
|
|
|
|
27
|
|
433
|
4
|
|
|
|
|
132
|
return $res; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
sub Run::redir::run { |
437
|
24
|
100
|
|
24
|
|
95
|
$_[1] = {} unless defined $_[1]; |
438
|
24
|
|
|
|
|
55
|
my ($tree, $data) = @_; |
439
|
24
|
|
|
|
|
85
|
my $cmd = $tree->[1]; |
440
|
24
|
|
|
|
|
84
|
local $data->{redir} = $data->{redir}; |
441
|
24
|
100
|
|
|
|
88
|
$data->{redir} = {} unless defined $data->{redir}; |
442
|
|
|
|
|
|
|
#local %{$data->{redir}} = %{$data->{redir}}; # Preserve data from being wiped |
443
|
24
|
|
|
|
|
40
|
my %oldredir = %{$data->{redir}}; # Preserve data from being wiped |
|
24
|
|
|
|
|
84
|
|
444
|
|
|
|
|
|
|
|
445
|
24
|
|
|
|
|
53
|
my $redir = $tree->[0]; |
446
|
24
|
|
|
|
|
94
|
my $unwind = []; |
447
|
24
|
|
|
|
|
123
|
my $print_errs = not exists $data->{errs}; |
448
|
24
|
50
|
|
|
|
95
|
my $errs = $print_errs ? [] : $data->{errs}; |
449
|
24
|
|
|
|
|
27
|
my $ret; |
450
|
24
|
50
|
|
|
|
164
|
if (cvt_2filehandle($redir,$unwind,$errs)) { # OK |
451
|
24
|
|
|
|
|
36
|
my ($fd, $rfd); |
452
|
24
|
100
|
|
|
|
40
|
if (%{$data->{redir}}) { |
|
24
|
|
|
|
|
152
|
|
453
|
1
|
|
|
|
|
3
|
for $fd (keys %$redir) { |
454
|
1
|
|
|
|
|
3
|
$rfd = fileno $redir->{$fd}{filehandle}; |
455
|
1
|
50
|
|
|
|
22
|
next unless exists $data->{redir}{$rfd}; # Target redirected already |
456
|
0
|
|
|
|
|
0
|
$redir->{$fd} = $data->{redir}{$rfd}; |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
} |
459
|
24
|
|
|
|
|
63
|
@{$data->{redir}}{keys %$redir} = values %$redir; |
|
24
|
|
|
|
|
74
|
|
460
|
|
|
|
|
|
|
|
461
|
24
|
|
|
|
|
111
|
$ret = $cmd->run($data); |
462
|
18
|
50
|
|
|
|
1176
|
return $ret unless @$unwind; |
463
|
|
|
|
|
|
|
} |
464
|
0
|
0
|
|
|
|
0
|
do_unwind($unwind,$errs) if @$unwind; |
465
|
|
|
|
|
|
|
# STDERR should not be redirected above, but signature of do_unwind is such... |
466
|
0
|
0
|
0
|
|
|
0
|
print STDERR join "\n", @$errs, "" if $print_errs and @$errs; |
467
|
0
|
|
|
|
|
0
|
%{$data->{redir}} = %oldredir; # Restore the data |
|
0
|
|
|
|
|
0
|
|
468
|
0
|
|
|
|
|
0
|
return $ret; |
469
|
|
|
|
|
|
|
} |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
sub Run::pipe::run { |
472
|
20
|
100
|
|
20
|
|
113
|
$_[1] = {} unless defined $_[1]; |
473
|
20
|
|
|
|
|
46
|
my ($tree, $data) = @_; |
474
|
20
|
|
|
|
|
76
|
my $cmd = $tree->[1]; |
475
|
20
|
|
|
|
|
41
|
my $dir = $tree->[0]; |
476
|
20
|
|
|
|
|
6641
|
require IO::Handle; |
477
|
20
|
|
|
|
|
106598
|
my $rpipe = IO::Handle->new; |
478
|
20
|
|
|
|
|
1083
|
my $wpipe = IO::Handle->new; |
479
|
|
|
|
|
|
|
|
480
|
20
|
50
|
|
|
|
401
|
print $SaveErr "pipe creation (parent will $dir)\n" if $Debug; |
481
|
20
|
50
|
|
|
|
1035
|
pipe($rpipe,$wpipe) |
482
|
|
|
|
|
|
|
or print(STDERR "cannot create pipe: $!\n"), return; |
483
|
20
|
50
|
|
|
|
74
|
print $SaveErr " --> ", fileno $rpipe, "\t\t\t\tread $rpipe\t\$^F=$^F\n" if $Debug; |
484
|
20
|
50
|
|
|
|
68
|
print $SaveErr " --> ", fileno $wpipe, "\t\t\t\twrite $wpipe\t\$^F=$^F\n" if $Debug; |
485
|
20
|
|
|
|
|
38
|
my ($toclose, $ret, $redir); |
486
|
|
|
|
|
|
|
|
487
|
20
|
100
|
|
|
|
95
|
if ($dir eq 'r') { |
488
|
15
|
|
|
|
|
148
|
$redir = new_redir({1 => {filehandle => $wpipe, mode => 'w'}}, $cmd); |
489
|
15
|
|
|
|
|
43
|
$toclose = $wpipe; |
490
|
15
|
|
|
|
|
25
|
$ret = $rpipe; |
491
|
|
|
|
|
|
|
} else { |
492
|
5
|
|
|
|
|
70
|
$redir = new_redir({0 => {filehandle => $rpipe, mode => 'r'}}, $cmd); |
493
|
5
|
|
|
|
|
10
|
$toclose = $rpipe; |
494
|
5
|
|
|
|
|
15
|
$ret = $wpipe; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
# XXXX Do not use unwind argument??? |
497
|
20
|
|
|
|
|
130
|
process_close_in_kid([$ret],[],{},[]); # XXXX No error handling here |
498
|
20
|
|
|
|
|
87
|
local $data->{'spawn'} = 1; |
499
|
20
|
50
|
|
|
|
97
|
$redir->run($data) or return; |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# XXXX This is not needed, since run() called unwind() which closed |
502
|
|
|
|
|
|
|
# fd=0/1, which invalidated $toclose anyway. |
503
|
|
|
|
|
|
|
|
504
|
15
|
50
|
|
|
|
657
|
xclose($toclose,[],"pipe::run: ") |
505
|
|
|
|
|
|
|
or print(STDERR "pipe::run: cannot close pipe end not belonging to me: $!\n"), return; |
506
|
15
|
|
|
|
|
3642
|
return $ret; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
sub Run::readpipe::run { |
510
|
4
|
50
|
|
4
|
|
32
|
$_[1] = {} unless defined $_[1]; |
511
|
4
|
|
|
|
|
28
|
my ($tree, $data) = @_; |
512
|
4
|
|
|
|
|
40
|
my $cmd = $tree->[0]; |
513
|
4
|
50
|
|
|
|
52
|
my $pipe = Run::pipe->new("r", $cmd)->run($data) or return; |
514
|
3
|
|
|
|
|
207
|
$pipe->input_record_separator(undef); |
515
|
3
|
|
|
|
|
1847415
|
return scalar <$pipe>; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
sub Run::readpipe_split::run { |
519
|
5
|
50
|
|
5
|
|
43
|
$_[1] = {} unless defined $_[1]; |
520
|
5
|
|
|
|
|
24
|
my ($tree, $data) = @_; |
521
|
5
|
|
|
|
|
31
|
my $cmd = $tree->[0]; |
522
|
5
|
50
|
|
|
|
72
|
my $pipe = Run::pipe->new("r", $cmd)->run($data) or return; |
523
|
3
|
|
|
|
|
222
|
$pipe->input_record_separator(undef); |
524
|
3
|
|
|
|
|
1937410
|
return split ' ', scalar <$pipe>; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
sub Run::base::new { |
528
|
57
|
|
|
57
|
|
284
|
my $class = shift; |
529
|
57
|
|
|
|
|
923
|
bless [@_], $class; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
sub Run::base2::new { |
533
|
48
|
|
|
48
|
|
176
|
my $class = shift; |
534
|
48
|
50
|
|
|
|
275
|
die "need two arguments in $class\->new" unless @_ == 2; |
535
|
48
|
|
|
|
|
349
|
bless [@_], $class; |
536
|
|
|
|
|
|
|
} |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
sub Run::base1::new { |
539
|
9
|
|
|
9
|
|
55
|
my $class = shift; |
540
|
9
|
50
|
|
|
|
74
|
die "need one argument in $class\->new" unless @_ == 1; |
541
|
9
|
|
|
|
|
92
|
bless [@_], $class; |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
48
|
|
|
48
|
0
|
7121679
|
sub new_system { Run::system->new(@_) } |
545
|
0
|
|
|
0
|
0
|
0
|
sub new_spawn { 'Run::spawn'->new(@_) } |
546
|
3
|
|
|
3
|
0
|
46
|
sub new_or { Run::or->new(@_) } |
547
|
3
|
|
|
3
|
0
|
32
|
sub new_and { Run::and->new(@_) } |
548
|
3
|
|
|
3
|
0
|
45
|
sub new_chain { Run::chain->new(@_) } |
549
|
4
|
|
|
4
|
0
|
81
|
sub new_env { Run::env->new(@_) } |
550
|
24
|
|
|
24
|
0
|
202
|
sub new_redir { Run::redir->new(@_) } |
551
|
11
|
|
|
11
|
0
|
133
|
sub new_pipe { Run::pipe->new(@_) } |
552
|
4
|
|
|
4
|
0
|
120
|
sub new_readpipe { Run::readpipe->new(@_) } |
553
|
5
|
|
|
5
|
0
|
81
|
sub new_readpipe_split { Run::readpipe_split->new(@_) } |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
1; |
556
|
|
|
|
|
|
|
__END__ |