line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2007-2019 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package IO::Async::Internals::ChildManager; |
7
|
|
|
|
|
|
|
|
8
|
41
|
|
|
41
|
|
313
|
use strict; |
|
41
|
|
|
|
|
86
|
|
|
41
|
|
|
|
|
1671
|
|
9
|
41
|
|
|
41
|
|
251
|
use warnings; |
|
41
|
|
|
|
|
91
|
|
|
41
|
|
|
|
|
2080
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.801'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# Not a notifier |
14
|
|
|
|
|
|
|
|
15
|
41
|
|
|
41
|
|
12445
|
use IO::Async::Stream; |
|
41
|
|
|
|
|
106
|
|
|
41
|
|
|
|
|
1431
|
|
16
|
|
|
|
|
|
|
|
17
|
41
|
|
|
41
|
|
278
|
use IO::Async::OS; |
|
41
|
|
|
|
|
111
|
|
|
41
|
|
|
|
|
1006
|
|
18
|
|
|
|
|
|
|
|
19
|
41
|
|
|
41
|
|
209
|
use Carp; |
|
41
|
|
|
|
|
150
|
|
|
41
|
|
|
|
|
2499
|
|
20
|
41
|
|
|
41
|
|
257
|
use Scalar::Util qw( weaken ); |
|
41
|
|
|
|
|
87
|
|
|
41
|
|
|
|
|
2088
|
|
21
|
|
|
|
|
|
|
|
22
|
41
|
|
|
41
|
|
259
|
use POSIX qw( _exit dup dup2 nice ); |
|
41
|
|
|
|
|
70
|
|
|
41
|
|
|
|
|
423
|
|
23
|
|
|
|
|
|
|
|
24
|
41
|
|
|
41
|
|
4973
|
use constant LENGTH_OF_I => length( pack( "I", 0 ) ); |
|
41
|
|
|
|
|
299
|
|
|
41
|
|
|
|
|
28415
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
# Writing to variables of $> and $) have tricky ways to obtain error results |
27
|
|
|
|
|
|
|
sub setuid |
28
|
|
|
|
|
|
|
{ |
29
|
0
|
|
|
0
|
0
|
0
|
my ( $uid ) = @_; |
30
|
|
|
|
|
|
|
|
31
|
0
|
|
|
|
|
0
|
$> = $uid; my $saved_errno = $!; |
|
0
|
|
|
|
|
0
|
|
32
|
0
|
0
|
|
|
|
0
|
$> == $uid and return 1; |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
0
|
$! = $saved_errno; |
35
|
0
|
|
|
|
|
0
|
return undef; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub setgid |
39
|
|
|
|
|
|
|
{ |
40
|
0
|
|
|
0
|
0
|
0
|
my ( $gid ) = @_; |
41
|
|
|
|
|
|
|
|
42
|
0
|
|
|
|
|
0
|
$) = $gid; my $saved_errno = $!; |
|
0
|
|
|
|
|
0
|
|
43
|
0
|
0
|
|
|
|
0
|
$) == $gid and return 1; |
44
|
|
|
|
|
|
|
|
45
|
0
|
|
|
|
|
0
|
$! = $saved_errno; |
46
|
0
|
|
|
|
|
0
|
return undef; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub setgroups |
50
|
|
|
|
|
|
|
{ |
51
|
0
|
|
|
0
|
0
|
0
|
my @groups = @_; |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
0
|
my $gid = $)+0; |
54
|
|
|
|
|
|
|
# Put the primary GID as the first group in the supplementary list, because |
55
|
|
|
|
|
|
|
# some operating systems ignore this position, expecting it to indeed be |
56
|
|
|
|
|
|
|
# the primary GID. |
57
|
|
|
|
|
|
|
# See |
58
|
|
|
|
|
|
|
# https://rt.cpan.org/Ticket/Display.html?id=65127 |
59
|
0
|
|
|
|
|
0
|
@groups = grep { $_ != $gid } @groups; |
|
0
|
|
|
|
|
0
|
|
60
|
|
|
|
|
|
|
|
61
|
0
|
|
|
|
|
0
|
$) = "$gid $gid " . join " ", @groups; my $saved_errno = $!; |
|
0
|
|
|
|
|
0
|
|
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# No easy way to detect success or failure. Just check that we have all and |
64
|
|
|
|
|
|
|
# only the right groups |
65
|
0
|
|
|
|
|
0
|
my %gotgroups = map { $_ => 1 } split ' ', "$)"; |
|
0
|
|
|
|
|
0
|
|
66
|
|
|
|
|
|
|
|
67
|
0
|
|
|
|
|
0
|
$! = $saved_errno; |
68
|
0
|
|
0
|
|
|
0
|
$gotgroups{$_}-- or return undef for @groups; |
69
|
0
|
0
|
|
|
|
0
|
keys %gotgroups or return undef; |
70
|
|
|
|
|
|
|
|
71
|
0
|
|
|
|
|
0
|
return 1; |
72
|
|
|
|
|
|
|
} |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Internal constructor |
75
|
|
|
|
|
|
|
sub new |
76
|
|
|
|
|
|
|
{ |
77
|
41
|
|
|
41
|
0
|
90
|
my $class = shift; |
78
|
41
|
|
|
|
|
153
|
my ( %params ) = @_; |
79
|
|
|
|
|
|
|
|
80
|
41
|
50
|
|
|
|
207
|
my $loop = delete $params{loop} or croak "Expected a 'loop'"; |
81
|
|
|
|
|
|
|
|
82
|
41
|
|
|
|
|
132
|
my $self = bless { |
83
|
|
|
|
|
|
|
loop => $loop, |
84
|
|
|
|
|
|
|
}, $class; |
85
|
|
|
|
|
|
|
|
86
|
41
|
|
|
|
|
3756
|
weaken( $self->{loop} ); |
87
|
|
|
|
|
|
|
|
88
|
41
|
|
|
|
|
273
|
return $self; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub spawn_child |
92
|
|
|
|
|
|
|
{ |
93
|
338
|
|
|
338
|
0
|
780
|
my $self = shift; |
94
|
338
|
|
|
|
|
1866
|
my %params = @_; |
95
|
|
|
|
|
|
|
|
96
|
338
|
|
|
|
|
1253
|
my $command = delete $params{command}; |
97
|
338
|
|
|
|
|
880
|
my $code = delete $params{code}; |
98
|
338
|
|
|
|
|
724
|
my $setup = delete $params{setup}; |
99
|
338
|
|
|
|
|
734
|
my $on_exit = delete $params{on_exit}; |
100
|
|
|
|
|
|
|
|
101
|
338
|
100
|
|
|
|
1077
|
if( %params ) { |
102
|
4
|
|
|
|
|
828
|
croak "Unrecognised options to spawn: " . join( ",", keys %params ); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
334
|
100
|
100
|
|
|
2557
|
defined $command and defined $code and |
106
|
|
|
|
|
|
|
croak "Cannot pass both 'command' and 'code' to spawn"; |
107
|
|
|
|
|
|
|
|
108
|
330
|
100
|
100
|
|
|
2818
|
defined $command or defined $code or |
109
|
|
|
|
|
|
|
croak "Must pass one of 'command' or 'code' to spawn"; |
110
|
|
|
|
|
|
|
|
111
|
326
|
100
|
|
|
|
2129
|
my @setup = defined $setup ? $self->_check_setup_and_canonicise( $setup ) : (); |
112
|
|
|
|
|
|
|
|
113
|
324
|
|
|
|
|
821
|
my $loop = $self->{loop}; |
114
|
|
|
|
|
|
|
|
115
|
324
|
|
|
|
|
625
|
my ( $readpipe, $writepipe ); |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
{ |
118
|
|
|
|
|
|
|
# Ensure it's FD_CLOEXEC - this is a bit more portable than manually |
119
|
|
|
|
|
|
|
# fiddling with F_GETFL and F_SETFL (e.g. MSWin32) |
120
|
324
|
|
|
|
|
655
|
local $^F = -1; |
|
324
|
|
|
|
|
3232
|
|
121
|
|
|
|
|
|
|
|
122
|
324
|
50
|
|
|
|
3492
|
( $readpipe, $writepipe ) = IO::Async::OS->pipepair or croak "Cannot pipe() - $!"; |
123
|
324
|
|
|
|
|
4111
|
$readpipe->blocking( 0 ); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
324
|
100
|
|
|
|
1754
|
if( defined $command ) { |
127
|
123
|
100
|
|
|
|
1131
|
my @command = ref( $command ) ? @$command : ( $command ); |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
$code = sub { |
130
|
41
|
|
|
41
|
|
328
|
no warnings; |
|
41
|
|
|
|
|
83
|
|
|
41
|
|
|
|
|
80971
|
|
131
|
28
|
|
|
28
|
|
0
|
exec( @command ); |
132
|
0
|
|
|
|
|
0
|
return; |
133
|
123
|
|
|
|
|
1359
|
}; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
my $kid = $loop->fork( |
137
|
|
|
|
|
|
|
code => sub { |
138
|
|
|
|
|
|
|
# Child |
139
|
29
|
|
|
29
|
|
1295
|
close( $readpipe ); |
140
|
29
|
|
|
|
|
1354
|
$self->_spawn_in_child( $writepipe, $code, \@setup ); |
141
|
|
|
|
|
|
|
}, |
142
|
324
|
|
|
|
|
3455
|
); |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Parent |
145
|
295
|
|
|
|
|
23577
|
close( $writepipe ); |
146
|
295
|
|
|
|
|
8867
|
return $self->_spawn_in_parent( $readpipe, $kid, $on_exit ); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub _check_setup_and_canonicise |
150
|
|
|
|
|
|
|
{ |
151
|
303
|
|
|
303
|
|
761
|
my $self = shift; |
152
|
303
|
|
|
|
|
817
|
my ( $setup ) = @_; |
153
|
|
|
|
|
|
|
|
154
|
303
|
100
|
|
|
|
1994
|
ref $setup eq "ARRAY" or croak "'setup' must be an ARRAY reference"; |
155
|
|
|
|
|
|
|
|
156
|
302
|
100
|
|
|
|
1065
|
return () if !@$setup; |
157
|
|
|
|
|
|
|
|
158
|
249
|
|
|
|
|
578
|
my @setup; |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
my $has_setgroups; |
161
|
|
|
|
|
|
|
|
162
|
249
|
|
|
|
|
1915
|
foreach my $i ( 0 .. $#$setup / 2 ) { |
163
|
431
|
|
|
|
|
2242
|
my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
# Rewrite stdin/stdout/stderr |
166
|
431
|
100
|
|
|
|
1349
|
$key eq "stdin" and $key = "fd0"; |
167
|
431
|
100
|
|
|
|
1127
|
$key eq "stdout" and $key = "fd1"; |
168
|
431
|
100
|
|
|
|
1006
|
$key eq "stderr" and $key = "fd2"; |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# Rewrite other filehandles |
171
|
431
|
100
|
66
|
|
|
1521
|
ref $key and eval { $key->fileno; 1 } and $key = "fd" . $key->fileno; |
|
127
|
|
|
|
|
624
|
|
|
127
|
|
|
|
|
1170
|
|
172
|
|
|
|
|
|
|
|
173
|
431
|
100
|
|
|
|
4085
|
if( $key =~ m/^fd(\d+)$/ ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
174
|
419
|
|
|
|
|
1623
|
my $fd = $1; |
175
|
419
|
|
|
|
|
1137
|
my $ref = ref $value; |
176
|
|
|
|
|
|
|
|
177
|
419
|
100
|
66
|
|
|
1580
|
if( !$ref ) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
178
|
128
|
|
|
|
|
396
|
$value = [ $value ]; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
elsif( $ref eq "ARRAY" ) { |
181
|
|
|
|
|
|
|
# Already OK |
182
|
|
|
|
|
|
|
} |
183
|
2
|
|
|
|
|
27
|
elsif( $ref eq "GLOB" or eval { $value->isa( "IO::Handle" ) } ) { |
184
|
38
|
|
|
|
|
129
|
$value = [ 'dup', $value ]; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
else { |
187
|
0
|
|
|
|
|
0
|
croak "Unrecognised reference type '$ref' for file descriptor $fd"; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
419
|
|
|
|
|
902
|
my $operation = $value->[0]; |
191
|
419
|
50
|
|
|
|
994
|
grep { $_ eq $operation } qw( open close dup keep ) or |
|
1676
|
|
|
|
|
3913
|
|
192
|
|
|
|
|
|
|
croak "Unrecognised operation '$operation' for file descriptor $fd"; |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
elsif( $key eq "env" ) { |
195
|
3
|
50
|
|
|
|
50
|
ref $value eq "HASH" or croak "Expected HASH reference for 'env' setup key"; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
elsif( $key eq "nice" ) { |
198
|
1
|
50
|
|
|
|
32
|
$value =~ m/^\d+$/ or croak "Expected integer for 'nice' setup key"; |
199
|
|
|
|
|
|
|
} |
200
|
|
|
|
|
|
|
elsif( $key eq "chdir" ) { |
201
|
|
|
|
|
|
|
# This isn't a purely watertight test, but it does guard against |
202
|
|
|
|
|
|
|
# silly things like passing a reference - directories such as |
203
|
|
|
|
|
|
|
# ARRAY(0x12345) are unlikely to exist |
204
|
1
|
50
|
|
|
|
40
|
-d $value or croak "Working directory '$value' does not exist"; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
elsif( $key eq "setuid" ) { |
207
|
2
|
50
|
|
|
|
11
|
$value =~ m/^\d+$/ or croak "Expected integer for 'setuid' setup key"; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
elsif( $key eq "setgid" ) { |
210
|
2
|
50
|
|
|
|
17
|
$value =~ m/^\d+$/ or croak "Expected integer for 'setgid' setup key"; |
211
|
2
|
50
|
|
|
|
7
|
$has_setgroups and carp "It is suggested to 'setgid' before 'setgroups'"; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
elsif( $key eq "setgroups" ) { |
214
|
2
|
50
|
|
|
|
8
|
ref $value eq "ARRAY" or croak "Expected ARRAY reference for 'setgroups' setup key"; |
215
|
2
|
|
33
|
|
|
38
|
m/^\d+$/ or croak "Expected integer in 'setgroups' array" for @$value; |
216
|
2
|
|
|
|
|
6
|
$has_setgroups = 1; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
else { |
219
|
1
|
|
|
|
|
124
|
croak "Unrecognised setup operation '$key'"; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
430
|
|
|
|
|
1721
|
push @setup, $key => $value; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
248
|
|
|
|
|
1071
|
return @setup; |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
sub _spawn_in_parent |
229
|
|
|
|
|
|
|
{ |
230
|
295
|
|
|
295
|
|
3069
|
my $self = shift; |
231
|
295
|
|
|
|
|
3922
|
my ( $readpipe, $kid, $on_exit ) = @_; |
232
|
|
|
|
|
|
|
|
233
|
295
|
|
|
|
|
1212
|
my $loop = $self->{loop}; |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
# We need to wait for both the errno pipe to close, and for waitpid |
236
|
|
|
|
|
|
|
# to give us an exit code. We'll form two closures over these two |
237
|
|
|
|
|
|
|
# variables so we can cope with those happening in either order |
238
|
|
|
|
|
|
|
|
239
|
295
|
|
|
|
|
1237
|
my $dollarbang; |
240
|
295
|
|
|
|
|
1733
|
my ( $dollarat, $length_dollarat ); |
241
|
295
|
|
|
|
|
0
|
my $exitcode; |
242
|
295
|
|
|
|
|
10787
|
my $pipeclosed = 0; |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
$loop->add( IO::Async::Stream->new( |
245
|
|
|
|
|
|
|
notifier_name => "statuspipe,kid=$kid", |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
read_handle => $readpipe, |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
on_read => sub { |
250
|
670
|
|
|
670
|
|
1770
|
my ( $self, $buffref, $eof ) = @_; |
251
|
|
|
|
|
|
|
|
252
|
670
|
100
|
|
|
|
2972
|
if( !defined $dollarbang ) { |
|
|
100
|
|
|
|
|
|
253
|
288
|
100
|
|
|
|
1181
|
if( length( $$buffref ) >= 2 * LENGTH_OF_I ) { |
254
|
194
|
|
|
|
|
1563
|
( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref ); |
255
|
194
|
|
|
|
|
773
|
substr( $$buffref, 0, 2 * LENGTH_OF_I, "" ); |
256
|
194
|
|
|
|
|
817
|
return 1; |
257
|
|
|
|
|
|
|
} |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
elsif( !defined $dollarat ) { |
260
|
191
|
50
|
|
|
|
835
|
if( length( $$buffref ) >= $length_dollarat ) { |
261
|
191
|
|
|
|
|
694
|
$dollarat = substr( $$buffref, 0, $length_dollarat, "" ); |
262
|
191
|
|
|
|
|
732
|
return 1; |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
|
266
|
285
|
50
|
|
|
|
890
|
if( $eof ) { |
267
|
285
|
100
|
|
|
|
1111
|
$dollarbang = 0 if !defined $dollarbang; |
268
|
285
|
100
|
|
|
|
842
|
if( !defined $length_dollarat ) { |
269
|
94
|
|
|
|
|
562
|
$length_dollarat = 0; |
270
|
94
|
|
|
|
|
830
|
$dollarat = ""; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
285
|
|
|
|
|
635
|
$pipeclosed = 1; |
274
|
|
|
|
|
|
|
|
275
|
285
|
100
|
|
|
|
910
|
if( defined $exitcode ) { |
276
|
118
|
|
|
|
|
1521
|
local $! = $dollarbang; |
277
|
118
|
|
|
|
|
536
|
$on_exit->( $kid, $exitcode, $!, $dollarat ); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
285
|
|
|
|
|
5398
|
return 0; |
282
|
|
|
|
|
|
|
} |
283
|
295
|
|
|
|
|
33476
|
) ); |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
$loop->watch_process( $kid => sub { |
286
|
287
|
|
|
287
|
|
1298
|
( my $kid, $exitcode ) = @_; |
287
|
|
|
|
|
|
|
|
288
|
287
|
100
|
|
|
|
1080
|
if( $pipeclosed ) { |
289
|
166
|
|
|
|
|
3431
|
local $! = $dollarbang; |
290
|
166
|
|
|
|
|
1327
|
$on_exit->( $kid, $exitcode, $!, $dollarat ); |
291
|
|
|
|
|
|
|
} |
292
|
295
|
|
|
|
|
11103
|
} ); |
293
|
|
|
|
|
|
|
|
294
|
295
|
|
|
|
|
28114
|
return $kid; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
sub _spawn_in_child |
298
|
|
|
|
|
|
|
{ |
299
|
29
|
|
|
29
|
|
465
|
my $self = shift; |
300
|
29
|
|
|
|
|
538
|
my ( $writepipe, $code, $setup ) = @_; |
301
|
|
|
|
|
|
|
|
302
|
29
|
|
|
|
|
310
|
my $exitvalue = eval { |
303
|
|
|
|
|
|
|
# Map of which handles will be in use by the end |
304
|
29
|
|
|
|
|
1233
|
my %fd_in_use = ( 0 => 1, 1 => 1, 2 => 1 ); # Keep STDIN, STDOUT, STDERR |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# Count of how many times we'll need to use the current handles. |
307
|
29
|
|
|
|
|
562
|
my %fds_refcount = %fd_in_use; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
# To dup2() without clashes we might need to temporarily move some handles |
310
|
29
|
|
|
|
|
279
|
my %dup_from; |
311
|
|
|
|
|
|
|
|
312
|
29
|
|
|
|
|
246
|
my $max_fd = 0; |
313
|
29
|
|
|
|
|
337
|
my $writepipe_clashes = 0; |
314
|
|
|
|
|
|
|
|
315
|
29
|
100
|
|
|
|
672
|
if( @$setup ) { |
316
|
|
|
|
|
|
|
# The writepipe might be in the way of a setup filedescriptor. If it |
317
|
|
|
|
|
|
|
# is we'll have to dup2 it out of the way then close the original. |
318
|
22
|
|
|
|
|
627
|
foreach my $i ( 0 .. $#$setup/2 ) { |
319
|
41
|
|
|
|
|
669
|
my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; |
320
|
41
|
50
|
|
|
|
1489
|
$key =~ m/^fd(\d+)$/ or next; |
321
|
41
|
|
|
|
|
451
|
my $fd = $1; |
322
|
|
|
|
|
|
|
|
323
|
41
|
100
|
|
|
|
476
|
$max_fd = $fd if $fd > $max_fd; |
324
|
41
|
50
|
|
|
|
384
|
$writepipe_clashes = 1 if $fd == fileno $writepipe; |
325
|
|
|
|
|
|
|
|
326
|
41
|
|
|
|
|
551
|
my ( $operation, @params ) = @$value; |
327
|
|
|
|
|
|
|
|
328
|
41
|
50
|
|
|
|
358
|
$operation eq "close" and do { |
329
|
0
|
|
|
|
|
0
|
delete $fd_in_use{$fd}; |
330
|
0
|
|
|
|
|
0
|
delete $fds_refcount{$fd}; |
331
|
|
|
|
|
|
|
}; |
332
|
|
|
|
|
|
|
|
333
|
41
|
100
|
|
|
|
489
|
$operation eq "dup" and do { |
334
|
39
|
|
|
|
|
193
|
$fd_in_use{$fd} = 1; |
335
|
|
|
|
|
|
|
|
336
|
39
|
|
|
|
|
274
|
my $fileno = fileno $params[0]; |
337
|
|
|
|
|
|
|
# Keep a count of how many times it will be dup'ed from so we |
338
|
|
|
|
|
|
|
# can close it once we've finished |
339
|
39
|
|
|
|
|
566
|
$fds_refcount{$fileno}++; |
340
|
|
|
|
|
|
|
|
341
|
39
|
|
|
|
|
217
|
$dup_from{$fileno} = $fileno; |
342
|
|
|
|
|
|
|
}; |
343
|
|
|
|
|
|
|
|
344
|
41
|
100
|
|
|
|
417
|
$operation eq "keep" and do { |
345
|
2
|
|
|
|
|
22
|
$fds_refcount{$fd} = 1; |
346
|
|
|
|
|
|
|
}; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
29
|
|
|
|
|
3624
|
foreach ( IO::Async::OS->potentially_open_fds ) { |
351
|
350
|
100
|
|
|
|
1269
|
next if $fds_refcount{$_}; |
352
|
222
|
100
|
|
|
|
1084
|
next if $_ == fileno $writepipe; |
353
|
193
|
|
|
|
|
2069
|
POSIX::close( $_ ); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
29
|
100
|
|
|
|
437
|
if( @$setup ) { |
357
|
22
|
50
|
|
|
|
362
|
if( $writepipe_clashes ) { |
358
|
0
|
|
|
|
|
0
|
$max_fd++; |
359
|
|
|
|
|
|
|
|
360
|
0
|
0
|
|
|
|
0
|
dup2( fileno $writepipe, $max_fd ) or die "Cannot dup2(writepipe to $max_fd) - $!\n"; |
361
|
0
|
|
|
|
|
0
|
undef $writepipe; |
362
|
0
|
0
|
|
|
|
0
|
open( $writepipe, ">&=$max_fd" ) or die "Cannot fdopen($max_fd) as writepipe - $!\n"; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
22
|
|
|
|
|
300
|
foreach my $i ( 0 .. $#$setup/2 ) { |
366
|
41
|
|
|
|
|
436
|
my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; |
367
|
|
|
|
|
|
|
|
368
|
41
|
50
|
|
|
|
479
|
if( $key =~ m/^fd(\d+)$/ ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
369
|
41
|
|
|
|
|
171
|
my $fd = $1; |
370
|
41
|
|
|
|
|
294
|
my( $operation, @params ) = @$value; |
371
|
|
|
|
|
|
|
|
372
|
41
|
100
|
|
|
|
367
|
$operation eq "dup" and do { |
373
|
39
|
|
|
|
|
208
|
my $from = fileno $params[0]; |
374
|
|
|
|
|
|
|
|
375
|
39
|
50
|
|
|
|
338
|
if( $from != $fd ) { |
376
|
39
|
50
|
|
|
|
270
|
if( exists $dup_from{$fd} ) { |
377
|
0
|
0
|
|
|
|
0
|
defined( $dup_from{$fd} = dup( $fd ) ) or die "Cannot dup($fd) - $!"; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
39
|
|
|
|
|
132
|
my $real_from = $dup_from{$from}; |
381
|
|
|
|
|
|
|
|
382
|
39
|
|
|
|
|
415
|
POSIX::close( $fd ); |
383
|
39
|
50
|
|
|
|
494
|
dup2( $real_from, $fd ) or die "Cannot dup2($real_from to $fd) - $!\n"; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
39
|
|
|
|
|
178
|
$fds_refcount{$from}--; |
387
|
39
|
50
|
33
|
|
|
533
|
if( !$fds_refcount{$from} and !$fd_in_use{$from} ) { |
388
|
39
|
|
|
|
|
421
|
POSIX::close( $from ); |
389
|
39
|
|
|
|
|
219
|
delete $dup_from{$from}; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
}; |
392
|
|
|
|
|
|
|
|
393
|
41
|
50
|
|
|
|
361
|
$operation eq "open" and do { |
394
|
0
|
|
|
|
|
0
|
my ( $mode, $filename ) = @params; |
395
|
0
|
0
|
|
|
|
0
|
open( my $fh, $mode, $filename ) or die "Cannot open('$mode', '$filename') - $!\n"; |
396
|
|
|
|
|
|
|
|
397
|
0
|
|
|
|
|
0
|
my $from = fileno $fh; |
398
|
0
|
0
|
|
|
|
0
|
dup2( $from, $fd ) or die "Cannot dup2($from to $fd) - $!\n"; |
399
|
|
|
|
|
|
|
|
400
|
0
|
|
|
|
|
0
|
close $fh; |
401
|
|
|
|
|
|
|
}; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
elsif( $key eq "env" ) { |
404
|
0
|
|
|
|
|
0
|
%ENV = %$value; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
elsif( $key eq "nice" ) { |
407
|
0
|
0
|
|
|
|
0
|
nice( $value ) or die "Cannot nice($value) - $!"; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
elsif( $key eq "chdir" ) { |
410
|
0
|
0
|
|
|
|
0
|
chdir( $value ) or die "Cannot chdir('$value') - $!"; |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
elsif( $key eq "setuid" ) { |
413
|
0
|
0
|
|
|
|
0
|
setuid( $value ) or die "Cannot setuid('$value') - $!"; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
elsif( $key eq "setgid" ) { |
416
|
0
|
0
|
|
|
|
0
|
setgid( $value ) or die "Cannot setgid('$value') - $!"; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
elsif( $key eq "setgroups" ) { |
419
|
0
|
0
|
|
|
|
0
|
setgroups( @$value ) or die "Cannot setgroups() - $!"; |
420
|
|
|
|
|
|
|
} |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
29
|
|
|
|
|
250
|
$code->(); |
425
|
|
|
|
|
|
|
}; |
426
|
|
|
|
|
|
|
|
427
|
0
|
|
|
|
|
|
my $writebuffer = ""; |
428
|
0
|
|
|
|
|
|
$writebuffer .= pack( "I", $!+0 ); |
429
|
0
|
|
|
|
|
|
$writebuffer .= pack( "I", length( $@ ) ) . $@; |
430
|
|
|
|
|
|
|
|
431
|
0
|
|
|
|
|
|
syswrite( $writepipe, $writebuffer ); |
432
|
|
|
|
|
|
|
|
433
|
0
|
|
|
|
|
|
return $exitvalue; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
0x55AA; |