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 6package IO::Async::Internals::ChildManager; 7 8use strict; 9use warnings; 10 11our $VERSION = '0.800'; 12 13# Not a notifier 14 15use IO::Async::Stream; 16 17use IO::Async::OS; 18 19use Carp; 20use Scalar::Util qw( weaken ); 21 22use POSIX qw( _exit dup dup2 nice ); 23 24use constant LENGTH_OF_I => length( pack( "I", 0 ) ); 25 26# Writing to variables of $> and $) have tricky ways to obtain error results 27sub setuid 28{ 29 my ( $uid ) = @_; 30 31 $> = $uid; my $saved_errno = $!; 32 $> == $uid and return 1; 33 34 $! = $saved_errno; 35 return undef; 36} 37 38sub setgid 39{ 40 my ( $gid ) = @_; 41 42 $) = $gid; my $saved_errno = $!; 43 $) == $gid and return 1; 44 45 $! = $saved_errno; 46 return undef; 47} 48 49sub setgroups 50{ 51 my @groups = @_; 52 53 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 @groups = grep { $_ != $gid } @groups; 60 61 $) = "$gid $gid " . join " ", @groups; my $saved_errno = $!; 62 63 # No easy way to detect success or failure. Just check that we have all and 64 # only the right groups 65 my %gotgroups = map { $_ => 1 } split ' ', "$)"; 66 67 $! = $saved_errno; 68 $gotgroups{$_}-- or return undef for @groups; 69 keys %gotgroups or return undef; 70 71 return 1; 72} 73 74# Internal constructor 75sub new 76{ 77 my $class = shift; 78 my ( %params ) = @_; 79 80 my $loop = delete $params{loop} or croak "Expected a 'loop'"; 81 82 my $self = bless { 83 loop => $loop, 84 }, $class; 85 86 weaken( $self->{loop} ); 87 88 return $self; 89} 90 91sub spawn_child 92{ 93 my $self = shift; 94 my %params = @_; 95 96 my $command = delete $params{command}; 97 my $code = delete $params{code}; 98 my $setup = delete $params{setup}; 99 my $on_exit = delete $params{on_exit}; 100 101 if( %params ) { 102 croak "Unrecognised options to spawn: " . join( ",", keys %params ); 103 } 104 105 defined $command and defined $code and 106 croak "Cannot pass both 'command' and 'code' to spawn"; 107 108 defined $command or defined $code or 109 croak "Must pass one of 'command' or 'code' to spawn"; 110 111 my @setup = defined $setup ? $self->_check_setup_and_canonicise( $setup ) : (); 112 113 my $loop = $self->{loop}; 114 115 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 local $^F = -1; 121 122 ( $readpipe, $writepipe ) = IO::Async::OS->pipepair or croak "Cannot pipe() - $!"; 123 $readpipe->blocking( 0 ); 124 } 125 126 if( defined $command ) { 127 my @command = ref( $command ) ? @$command : ( $command ); 128 129 $code = sub { 130 no warnings; 131 exec( @command ); 132 return; 133 }; 134 } 135 136 my $kid = $loop->fork( 137 code => sub { 138 # Child 139 close( $readpipe ); 140 $self->_spawn_in_child( $writepipe, $code, \@setup ); 141 }, 142 ); 143 144 # Parent 145 close( $writepipe ); 146 return $self->_spawn_in_parent( $readpipe, $kid, $on_exit ); 147} 148 149sub _check_setup_and_canonicise 150{ 151 my $self = shift; 152 my ( $setup ) = @_; 153 154 ref $setup eq "ARRAY" or croak "'setup' must be an ARRAY reference"; 155 156 return () if !@$setup; 157 158 my @setup; 159 160 my $has_setgroups; 161 162 foreach my $i ( 0 .. $#$setup / 2 ) { 163 my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; 164 165 # Rewrite stdin/stdout/stderr 166 $key eq "stdin" and $key = "fd0"; 167 $key eq "stdout" and $key = "fd1"; 168 $key eq "stderr" and $key = "fd2"; 169 170 # Rewrite other filehandles 171 ref $key and eval { $key->fileno; 1 } and $key = "fd" . $key->fileno; 172 173 if( $key =~ m/^fd(\d+)$/ ) { 174 my $fd = $1; 175 my $ref = ref $value; 176 177 if( !$ref ) { 178 $value = [ $value ]; 179 } 180 elsif( $ref eq "ARRAY" ) { 181 # Already OK 182 } 183 elsif( $ref eq "GLOB" or eval { $value->isa( "IO::Handle" ) } ) { 184 $value = [ 'dup', $value ]; 185 } 186 else { 187 croak "Unrecognised reference type '$ref' for file descriptor $fd"; 188 } 189 190 my $operation = $value->[0]; 191 grep { $_ eq $operation } qw( open close dup keep ) or 192 croak "Unrecognised operation '$operation' for file descriptor $fd"; 193 } 194 elsif( $key eq "env" ) { 195 ref $value eq "HASH" or croak "Expected HASH reference for 'env' setup key"; 196 } 197 elsif( $key eq "nice" ) { 198 $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 -d $value or croak "Working directory '$value' does not exist"; 205 } 206 elsif( $key eq "setuid" ) { 207 $value =~ m/^\d+$/ or croak "Expected integer for 'setuid' setup key"; 208 } 209 elsif( $key eq "setgid" ) { 210 $value =~ m/^\d+$/ or croak "Expected integer for 'setgid' setup key"; 211 $has_setgroups and carp "It is suggested to 'setgid' before 'setgroups'"; 212 } 213 elsif( $key eq "setgroups" ) { 214 ref $value eq "ARRAY" or croak "Expected ARRAY reference for 'setgroups' setup key"; 215 m/^\d+$/ or croak "Expected integer in 'setgroups' array" for @$value; 216 $has_setgroups = 1; 217 } 218 else { 219 croak "Unrecognised setup operation '$key'"; 220 } 221 222 push @setup, $key => $value; 223 } 224 225 return @setup; 226} 227 228sub _spawn_in_parent 229{ 230 my $self = shift; 231 my ( $readpipe, $kid, $on_exit ) = @_; 232 233 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 my $dollarbang; 240 my ( $dollarat, $length_dollarat ); 241 my $exitcode; 242 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 my ( $self, $buffref, $eof ) = @_; 251 252 if( !defined $dollarbang ) { 253 if( length( $$buffref ) >= 2 * LENGTH_OF_I ) { 254 ( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref ); 255 substr( $$buffref, 0, 2 * LENGTH_OF_I, "" ); 256 return 1; 257 } 258 } 259 elsif( !defined $dollarat ) { 260 if( length( $$buffref ) >= $length_dollarat ) { 261 $dollarat = substr( $$buffref, 0, $length_dollarat, "" ); 262 return 1; 263 } 264 } 265 266 if( $eof ) { 267 $dollarbang = 0 if !defined $dollarbang; 268 if( !defined $length_dollarat ) { 269 $length_dollarat = 0; 270 $dollarat = ""; 271 } 272 273 $pipeclosed = 1; 274 275 if( defined $exitcode ) { 276 local $! = $dollarbang; 277 $on_exit->( $kid, $exitcode, $!, $dollarat ); 278 } 279 } 280 281 return 0; 282 } 283 ) ); 284 285 $loop->watch_process( $kid => sub { 286 ( my $kid, $exitcode ) = @_; 287 288 if( $pipeclosed ) { 289 local $! = $dollarbang; 290 $on_exit->( $kid, $exitcode, $!, $dollarat ); 291 } 292 } ); 293 294 return $kid; 295} 296 297sub _spawn_in_child 298{ 299 my $self = shift; 300 my ( $writepipe, $code, $setup ) = @_; 301 302 my $exitvalue = eval { 303 # Map of which handles will be in use by the end 304 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 my %fds_refcount = %fd_in_use; 308 309 # To dup2() without clashes we might need to temporarily move some handles 310 my %dup_from; 311 312 my $max_fd = 0; 313 my $writepipe_clashes = 0; 314 315 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 foreach my $i ( 0 .. $#$setup/2 ) { 319 my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; 320 $key =~ m/^fd(\d+)$/ or next; 321 my $fd = $1; 322 323 $max_fd = $fd if $fd > $max_fd; 324 $writepipe_clashes = 1 if $fd == fileno $writepipe; 325 326 my ( $operation, @params ) = @$value; 327 328 $operation eq "close" and do { 329 delete $fd_in_use{$fd}; 330 delete $fds_refcount{$fd}; 331 }; 332 333 $operation eq "dup" and do { 334 $fd_in_use{$fd} = 1; 335 336 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 $fds_refcount{$fileno}++; 340 341 $dup_from{$fileno} = $fileno; 342 }; 343 344 $operation eq "keep" and do { 345 $fds_refcount{$fd} = 1; 346 }; 347 } 348 } 349 350 foreach ( IO::Async::OS->potentially_open_fds ) { 351 next if $fds_refcount{$_}; 352 next if $_ == fileno $writepipe; 353 POSIX::close( $_ ); 354 } 355 356 if( @$setup ) { 357 if( $writepipe_clashes ) { 358 $max_fd++; 359 360 dup2( fileno $writepipe, $max_fd ) or die "Cannot dup2(writepipe to $max_fd) - $!\n"; 361 undef $writepipe; 362 open( $writepipe, ">&=$max_fd" ) or die "Cannot fdopen($max_fd) as writepipe - $!\n"; 363 } 364 365 foreach my $i ( 0 .. $#$setup/2 ) { 366 my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; 367 368 if( $key =~ m/^fd(\d+)$/ ) { 369 my $fd = $1; 370 my( $operation, @params ) = @$value; 371 372 $operation eq "dup" and do { 373 my $from = fileno $params[0]; 374 375 if( $from != $fd ) { 376 if( exists $dup_from{$fd} ) { 377 defined( $dup_from{$fd} = dup( $fd ) ) or die "Cannot dup($fd) - $!"; 378 } 379 380 my $real_from = $dup_from{$from}; 381 382 POSIX::close( $fd ); 383 dup2( $real_from, $fd ) or die "Cannot dup2($real_from to $fd) - $!\n"; 384 } 385 386 $fds_refcount{$from}--; 387 if( !$fds_refcount{$from} and !$fd_in_use{$from} ) { 388 POSIX::close( $from ); 389 delete $dup_from{$from}; 390 } 391 }; 392 393 $operation eq "open" and do { 394 my ( $mode, $filename ) = @params; 395 open( my $fh, $mode, $filename ) or die "Cannot open('$mode', '$filename') - $!\n"; 396 397 my $from = fileno $fh; 398 dup2( $from, $fd ) or die "Cannot dup2($from to $fd) - $!\n"; 399 400 close $fh; 401 }; 402 } 403 elsif( $key eq "env" ) { 404 %ENV = %$value; 405 } 406 elsif( $key eq "nice" ) { 407 nice( $value ) or die "Cannot nice($value) - $!"; 408 } 409 elsif( $key eq "chdir" ) { 410 chdir( $value ) or die "Cannot chdir('$value') - $!"; 411 } 412 elsif( $key eq "setuid" ) { 413 setuid( $value ) or die "Cannot setuid('$value') - $!"; 414 } 415 elsif( $key eq "setgid" ) { 416 setgid( $value ) or die "Cannot setgid('$value') - $!"; 417 } 418 elsif( $key eq "setgroups" ) { 419 setgroups( @$value ) or die "Cannot setgroups() - $!"; 420 } 421 } 422 } 423 424 $code->(); 425 }; 426 427 my $writebuffer = ""; 428 $writebuffer .= pack( "I", $!+0 ); 429 $writebuffer .= pack( "I", length( $@ ) ) . $@; 430 431 syswrite( $writepipe, $writebuffer ); 432 433 return $exitvalue; 434} 435 4360x55AA; 437