diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IPC')
-rw-r--r-- | Master/tlpkg/tlperl/lib/IPC/Cmd.pm | 593 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/IPC/Open3.pm | 12 |
2 files changed, 387 insertions, 218 deletions
diff --git a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm index c3d18b54617..6a82bdff9bd 100644 --- a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm +++ b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm @@ -15,9 +15,10 @@ BEGIN { use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN $INSTANCES $ALLOW_NULL_ARGS + $HAVE_MONOTONIC ]; - $VERSION = '0.80'; + $VERSION = '0.92'; $VERBOSE = 0; $DEBUG = 0; $WARN = 1; @@ -32,18 +33,27 @@ BEGIN { require IO::Select; IO::Select->import(); require IO::Handle; IO::Handle->import(); require FileHandle; FileHandle->import(); - require Socket; Socket->import(); + require Socket; require Time::HiRes; Time::HiRes->import(); require Win32 if IS_WIN32; }; $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32; + eval { + my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC); + }; + if ($@) { + $HAVE_MONOTONIC = 0; + } + else { + $HAVE_MONOTONIC = 1; + } + @ISA = qw[Exporter]; @EXPORT_OK = qw[can_run run run_forked QUOTE]; } require Carp; -use Socket; use File::Spec; use Params::Check qw[check]; use Text::ParseWords (); # import ONLY if needed! @@ -86,6 +96,13 @@ IPC::Cmd - finding and running system commands made easy print join "", @$full_buf; } + ### run_forked example ### + my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20}); + if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) { + print "this is what wget returned:\n"; + print $result->{'stdout'}; + } + ### check for features print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3; print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run; @@ -124,7 +141,7 @@ sub can_use_ipc_run { ### IPC::Run doesn't run on win98 return if IS_WIN98; - ### if we dont have ipc::run, we obviously can't use it. + ### if we don't have ipc::run, we obviously can't use it. return unless can_load( modules => { 'IPC::Run' => '0.55' }, verbose => ($WARN && $verbose), @@ -150,7 +167,7 @@ sub can_use_ipc_open3 { ### IPC::Open3 is not working on VMS because of a lack of fork. return if IS_VMS; - ### IPC::Open3 works on every non-VMS platform platform, but it can't + ### IPC::Open3 works on every non-VMS platform, but it can't ### capture buffers on win32 :( return unless can_load( modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| }, @@ -346,6 +363,42 @@ sub can_use_run_forked { return $CAN_USE_RUN_FORKED eq "1"; } +sub get_monotonic_time { + if ($HAVE_MONOTONIC) { + return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC); + } + else { + return time(); + } +} + +sub adjust_monotonic_start_time { + my ($ref_vars, $now, $previous) = @_; + + # workaround only for those systems which don't have + # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular) + return if $HAVE_MONOTONIC; + + # don't have previous monotonic value (only happens once + # in the beginning of the program execution) + return unless $previous; + + my $time_diff = $now - $previous; + + # adjust previously saved time with the skew value which is + # either negative when clock moved back or more than 5 seconds -- + # assuming that event loop does happen more often than once + # per five seconds, which might not be always true (!) but + # hopefully that's ok, because it's just a workaround + if ($time_diff > 5 || $time_diff < 0) { + foreach my $ref_var (@{$ref_vars}) { + if (defined($$ref_var)) { + $$ref_var = $$ref_var + $time_diff; + } + } + } +} + # incompatible with POSIX::SigAction # sub install_layered_signal { @@ -353,9 +406,9 @@ sub install_layered_signal { my %available_signals = map {$_ => 1} keys %SIG; - die("install_layered_signal got nonexistent signal name [$s]") + Carp::confess("install_layered_signal got nonexistent signal name [$s]") unless defined($available_signals{$s}); - die("install_layered_signal expects coderef") + Carp::confess("install_layered_signal expects coderef") if !ref($handler_code) || ref($handler_code) ne 'CODE'; my $previous_handler = $SIG{$s}; @@ -413,14 +466,32 @@ sub kill_gently { kill(-15, $pid); } + my $do_wait = 1; my $child_finished = 0; - my $wait_start_time = time(); - while (!$child_finished && $wait_start_time + $opts->{'wait_time'} > time()) { + my $wait_start_time = get_monotonic_time(); + my $now; + my $previous_monotonic_value; + + while ($do_wait) { + $previous_monotonic_value = $now; + $now = get_monotonic_time(); + + adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value); + + if ($now > $wait_start_time + $opts->{'wait_time'}) { + $do_wait = 0; + next; + } + my $waitpid = waitpid($pid, POSIX::WNOHANG); + if ($waitpid eq -1) { - $child_finished = 1; + $child_finished = 1; + $do_wait = 0; + next; } + Time::HiRes::usleep(250000); # quarter of a second } @@ -435,173 +506,174 @@ sub kill_gently { } sub open3_run { - my ($cmd, $opts) = @_; + my ($cmd, $opts) = @_; - $opts = {} unless $opts; + $opts = {} unless $opts; - my $child_in = FileHandle->new; - my $child_out = FileHandle->new; - my $child_err = FileHandle->new; - $child_out->autoflush(1); - $child_err->autoflush(1); - - my $pid = open3($child_in, $child_out, $child_err, $cmd); - - # push my child's pid to our parent - # so in case i am killed parent - # could stop my child (search for - # child_child_pid in parent code) - if ($opts->{'parent_info'}) { - my $ps = $opts->{'parent_info'}; - print $ps "spawned $pid\n"; - } + my $child_in = FileHandle->new; + my $child_out = FileHandle->new; + my $child_err = FileHandle->new; + $child_out->autoflush(1); + $child_err->autoflush(1); + + my $pid = open3($child_in, $child_out, $child_err, $cmd); + + # push my child's pid to our parent + # so in case i am killed parent + # could stop my child (search for + # child_child_pid in parent code) + if ($opts->{'parent_info'}) { + my $ps = $opts->{'parent_info'}; + print $ps "spawned $pid\n"; + } - if ($child_in && $child_out->opened && $opts->{'child_stdin'}) { + if ($child_in && $child_out->opened && $opts->{'child_stdin'}) { + # If the child process dies for any reason, + # the next write to CHLD_IN is likely to generate + # a SIGPIPE in the parent, which is fatal by default. + # So you may wish to handle this signal. + # + # from http://perldoc.perl.org/IPC/Open3.html, + # absolutely needed to catch piped commands errors. + # + local $SIG{'PIPE'} = sub { 1; }; - # If the child process dies for any reason, - # the next write to CHLD_IN is likely to generate - # a SIGPIPE in the parent, which is fatal by default. - # So you may wish to handle this signal. - # - # from http://perldoc.perl.org/IPC/Open3.html, - # absolutely needed to catch piped commands errors. - # - local $SIG{'PIPE'} = sub { 1; }; + print $child_in $opts->{'child_stdin'}; + } + close($child_in); + + my $child_output = { + 'out' => $child_out->fileno, + 'err' => $child_err->fileno, + $child_out->fileno => { + 'parent_socket' => $opts->{'parent_stdout'}, + 'scalar_buffer' => "", + 'child_handle' => $child_out, + 'block_size' => ($child_out->stat)[11] || 1024, + }, + $child_err->fileno => { + 'parent_socket' => $opts->{'parent_stderr'}, + 'scalar_buffer' => "", + 'child_handle' => $child_err, + 'block_size' => ($child_err->stat)[11] || 1024, + }, + }; - print $child_in $opts->{'child_stdin'}; - } - close($child_in); - - my $child_output = { - 'out' => $child_out->fileno, - 'err' => $child_err->fileno, - $child_out->fileno => { - 'parent_socket' => $opts->{'parent_stdout'}, - 'scalar_buffer' => "", - 'child_handle' => $child_out, - 'block_size' => ($child_out->stat)[11] || 1024, - }, - $child_err->fileno => { - 'parent_socket' => $opts->{'parent_stderr'}, - 'scalar_buffer' => "", - 'child_handle' => $child_err, - 'block_size' => ($child_err->stat)[11] || 1024, - }, - }; + my $select = IO::Select->new(); + $select->add($child_out, $child_err); + + # pass any signal to the child + # effectively creating process + # strongly attached to the child: + # it will terminate only after child + # has terminated (except for SIGKILL, + # which is specially handled) + foreach my $s (keys %SIG) { + my $sig_handler; + $sig_handler = sub { + kill("$s", $pid); + $SIG{$s} = $sig_handler; + }; + $SIG{$s} = $sig_handler; + } - my $select = IO::Select->new(); - $select->add($child_out, $child_err); - - # pass any signal to the child - # effectively creating process - # strongly attached to the child: - # it will terminate only after child - # has terminated (except for SIGKILL, - # which is specially handled) - foreach my $s (keys %SIG) { - my $sig_handler; - $sig_handler = sub { - kill("$s", $pid); - $SIG{$s} = $sig_handler; - }; - $SIG{$s} = $sig_handler; - } + my $child_finished = 0; - my $child_finished = 0; + my $real_exit; + my $exit_value; - my $got_sig_child = 0; - $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + while(!$child_finished) { - while(!$child_finished && ($child_out->opened || $child_err->opened)) { + # parent was killed otherwise we would have got + # the same signal as parent and process it same way + if (getppid() eq "1") { - # parent was killed otherwise we would have got - # the same signal as parent and process it same way - if (getppid() eq "1") { + # end my process group with all the children + # (i am the process group leader, so my pid + # equals to the process group id) + # + # same thing which is done + # with $opts->{'clean_up_children'} + # in run_forked + # + kill(-9, $$); - # end my process group with all the children - # (i am the process group leader, so my pid - # equals to the process group id) - # - # same thing which is done - # with $opts->{'clean_up_children'} - # in run_forked - # - kill(-9, $$); + POSIX::_exit 1; + } - POSIX::_exit 1; - } + my $waitpid = waitpid($pid, POSIX::WNOHANG); - if ($got_sig_child) { - if (time() - $got_sig_child > 1) { - # select->can_read doesn't return 0 after SIG_CHLD - # - # "On POSIX-compliant platforms, SIGCHLD is the signal - # sent to a process when a child process terminates." - # http://en.wikipedia.org/wiki/SIGCHLD - # - # nevertheless kill KILL wouldn't break anything here - # - kill (9, $pid); - $child_finished = 1; - } - } + # child finished, catch it's exit status + if ($waitpid ne 0 && $waitpid ne -1) { + $real_exit = $?; + $exit_value = $? >> 8; + } + + if ($waitpid eq -1) { + $child_finished = 1; + } - Time::HiRes::usleep(1); - foreach my $fd ($select->can_read(1/100)) { - my $str = $child_output->{$fd->fileno}; - psSnake::die("child stream not found: $fd") unless $str; + my $ready_fds = []; + push @{$ready_fds}, $select->can_read(1/100); - my $data; - my $count = $fd->sysread($data, $str->{'block_size'}); + READY_FDS: while (scalar(@{$ready_fds})) { + my $fd = shift @{$ready_fds}; + $ready_fds = [grep {$_ ne $fd} @{$ready_fds}]; - if ($count) { - if ($str->{'parent_socket'}) { - my $ph = $str->{'parent_socket'}; - print $ph $data; - } - else { - $str->{'scalar_buffer'} .= $data; + my $str = $child_output->{$fd->fileno}; + Carp::confess("child stream not found: $fd") unless $str; + + my $data; + my $count = $fd->sysread($data, $str->{'block_size'}); + + if ($count) { + if ($str->{'parent_socket'}) { + my $ph = $str->{'parent_socket'}; + print $ph $data; + } + else { + $str->{'scalar_buffer'} .= $data; + } + } + elsif ($count eq 0) { + $select->remove($fd); + $fd->close(); + } + else { + Carp::confess("error during sysread: " . $!); + } + + push @{$ready_fds}, $select->can_read(1/100) if $child_finished; } - } - elsif ($count eq 0) { - $select->remove($fd); - $fd->close(); - } - else { - psSnake::die("error during sysread: " . $!); - } + + Time::HiRes::usleep(1); } - } - my $waitpid_ret = waitpid($pid, 0); - my $real_exit = $?; - my $exit_value = $real_exit >> 8; + # since we've successfully reaped the child, + # let our parent know about this. + # + if ($opts->{'parent_info'}) { + my $ps = $opts->{'parent_info'}; - # since we've successfully reaped the child, - # let our parent know about this. - # - if ($opts->{'parent_info'}) { - my $ps = $opts->{'parent_info'}; + # child was killed, inform parent + if ($real_exit & 127) { + print $ps "$pid killed with " . ($real_exit & 127) . "\n"; + } - # child was killed, inform parent - if ($real_exit & 127) { - print $ps "$pid killed with " . ($real_exit & 127) . "\n"; + print $ps "reaped $pid\n"; } - print $ps "reaped $pid\n"; - } - - if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) { - return $exit_value; - } - else { - return { - 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'}, - 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'}, - 'exit_code' => $exit_value, - }; - } + if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) { + return $exit_value; + } + else { + return { + 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'}, + 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'}, + 'exit_code' => $exit_value, + }; + } } =head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} ); @@ -638,7 +710,7 @@ Invocation requires the command to be executed or a coderef and optionally a has =item C<timeout> -Specify in seconds how long to run the command before it is killed with with SIG_KILL (9), +Specify in seconds how long to run the command before it is killed with SIG_KILL (9), which effectively terminates it and all of its children (direct or indirect). =item C<child_stdin> @@ -708,14 +780,17 @@ sub run_forked { ### container to store things in my $self = bless {}, __PACKAGE__; - require POSIX; - if (!can_use_run_forked()) { Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED"); return; } + require POSIX; + my ($cmd, $opts) = @_; + if (ref($cmd) eq 'ARRAY') { + $cmd = join(" ", @{$cmd}); + } if (!$cmd) { Carp::carp("run_forked expects command to run"); @@ -741,12 +816,12 @@ sub run_forked { my $child_info_socket; my $parent_info_socket; - socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || - die ("socketpair: $!"); - socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || - die ("socketpair: $!"); - socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || - die ("socketpair: $!"); + socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || + Carp::confess ("socketpair: $!"); + socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || + Carp::confess ("socketpair: $!"); + socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) || + Carp::confess ("socketpair: $!"); $child_stdout_socket->autoflush(1); $parent_stdout_socket->autoflush(1); @@ -755,7 +830,7 @@ sub run_forked { $child_info_socket->autoflush(1); $parent_info_socket->autoflush(1); - my $start_time = time(); + my $start_time = get_monotonic_time(); my $pid; if ($pid = fork) { @@ -770,22 +845,46 @@ sub run_forked { # prepare sockets to read from child $flags = 0; - fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; $flags |= POSIX::O_NONBLOCK; - fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; $flags = 0; - fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; $flags |= POSIX::O_NONBLOCK; - fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; $flags = 0; - fcntl($child_info_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + fcntl($child_info_socket, POSIX::F_GETFL, $flags) || Carp::confess "can't fnctl F_GETFL: $!"; $flags |= POSIX::O_NONBLOCK; - fcntl($child_info_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!"; # print "child $pid started\n"; + my $child_output = { + $child_stdout_socket->fileno => { + 'scalar_buffer' => "", + 'child_handle' => $child_stdout_socket, + 'block_size' => ($child_stdout_socket->stat)[11] || 1024, + 'protocol' => 'stdout', + }, + $child_stderr_socket->fileno => { + 'scalar_buffer' => "", + 'child_handle' => $child_stderr_socket, + 'block_size' => ($child_stderr_socket->stat)[11] || 1024, + 'protocol' => 'stderr', + }, + $child_info_socket->fileno => { + 'scalar_buffer' => "", + 'child_handle' => $child_info_socket, + 'block_size' => ($child_info_socket->stat)[11] || 1024, + 'protocol' => 'info', + }, + }; + + my $select = IO::Select->new(); + $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket); + my $child_timedout = 0; my $child_finished = 0; my $child_stdout = ''; @@ -795,27 +894,30 @@ sub run_forked { my $child_killed_by_signal = 0; my $parent_died = 0; + my $last_parent_check = 0; my $got_sig_child = 0; my $got_sig_quit = 0; my $orig_sig_child = $SIG{'CHLD'}; - $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); }; if ($opts->{'terminate_on_signal'}) { install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); }); } my $child_child_pid; + my $now; + my $previous_monotonic_value; while (!$child_finished) { - my $now = time(); + $previous_monotonic_value = $now; + $now = get_monotonic_time(); - if ($opts->{'terminate_on_parent_sudden_death'}) { - $opts->{'runtime'}->{'last_parent_check'} = 0 - unless defined($opts->{'runtime'}->{'last_parent_check'}); + adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value); + if ($opts->{'terminate_on_parent_sudden_death'}) { # check for parent once each five seconds - if ($now - $opts->{'runtime'}->{'last_parent_check'} > 5) { + if ($now > $last_parent_check + 5) { if (getppid() eq "1") { kill_gently ($pid, { 'first_kill_type' => 'process_group', @@ -825,13 +927,13 @@ sub run_forked { $parent_died = 1; } - $opts->{'runtime'}->{'last_parent_check'} = $now; + $last_parent_check = $now; } } # user specified timeout if ($opts->{'timeout'}) { - if ($now - $start_time > $opts->{'timeout'}) { + if ($now > $start_time + $opts->{'timeout'}) { kill_gently ($pid, { 'first_kill_type' => 'process_group', 'final_kill_type' => 'process_group', @@ -845,7 +947,7 @@ sub run_forked { # kill process after that and finish wait loop; # shouldn't ever happen -- remove this code? if ($got_sig_child) { - if ($now - $got_sig_child > 10) { + if ($now > $got_sig_child + 10) { print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n"; kill (-9, $pid); $child_finished = 1; @@ -870,43 +972,95 @@ sub run_forked { if ($waitpid eq -1) { $child_finished = 1; - next; } - # child -> parent simple internal communication protocol - while (my $l = <$child_info_socket>) { - if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) { - $child_child_pid = $1; - $l = $2; + my $ready_fds = []; + push @{$ready_fds}, $select->can_read(1/100); + + READY_FDS: while (scalar(@{$ready_fds})) { + my $fd = shift @{$ready_fds}; + $ready_fds = [grep {$_ ne $fd} @{$ready_fds}]; + + my $str = $child_output->{$fd->fileno}; + Carp::confess("child stream not found: $fd") unless $str; + + my $data = ""; + my $count = $fd->sysread($data, $str->{'block_size'}); + + if ($count) { + # extract all the available lines and store the rest in temporary buffer + if ($data =~ /(.+\n)([^\n]*)/so) { + $data = $str->{'scalar_buffer'} . $1; + $str->{'scalar_buffer'} = $2 || ""; + } + else { + $str->{'scalar_buffer'} .= $data; + $data = ""; + } } - if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) { - $child_child_pid = undef; - $l = $2; + elsif ($count eq 0) { + $select->remove($fd); + $fd->close(); + if ($str->{'scalar_buffer'}) { + $data = $str->{'scalar_buffer'} . "\n"; + } } - if ($l =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) { - $child_killed_by_signal = $1; - $l = $2; + else { + Carp::confess("error during sysread on [$fd]: " . $!); } - } - while (my $l = <$child_stdout_socket>) { - if (!$opts->{'discard_output'}) { - $child_stdout .= $l; - $child_merged .= $l; - } + # $data contains only full lines (or last line if it was unfinished read + # or now new-line in the output of the child); dat is processed + # according to the "protocol" of socket + if ($str->{'protocol'} eq 'info') { + if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) { + $child_child_pid = $1; + $data = $2; + } + if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) { + $child_child_pid = undef; + $data = $2; + } + if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) { + $child_killed_by_signal = $1; + $data = $2; + } - if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') { - $opts->{'stdout_handler'}->($l); + # we don't expect any other data in info socket, so it's + # some strange violation of protocol, better know about this + if ($data) { + Carp::confess("info protocol violation: [$data]"); + } } - } - while (my $l = <$child_stderr_socket>) { - if (!$opts->{'discard_output'}) { - $child_stderr .= $l; - $child_merged .= $l; + if ($str->{'protocol'} eq 'stdout') { + if (!$opts->{'discard_output'}) { + $child_stdout .= $data; + $child_merged .= $data; + } + + if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') { + $opts->{'stdout_handler'}->($data); + } } - if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') { - $opts->{'stderr_handler'}->($l); + if ($str->{'protocol'} eq 'stderr') { + if (!$opts->{'discard_output'}) { + $child_stderr .= $data; + $child_merged .= $data; + } + + if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') { + $opts->{'stderr_handler'}->($data); + } } + + # process may finish (waitpid returns -1) before + # we've read all of its output because of buffering; + # so try to read all the way it is possible to read + # in such case - this shouldn't be too much (unless + # the buffer size is HUGE -- should introduce + # another counter in such case, maybe later) + # + push @{$ready_fds}, $select->can_read(1/100) if $child_finished; } Time::HiRes::usleep(1); @@ -960,6 +1114,7 @@ sub run_forked { 'parent_died' => $parent_died, 'killed_by_signal' => $child_killed_by_signal, 'child_pgid' => $pid, + 'cmd' => $cmd, }; my $err_msg = ''; @@ -972,7 +1127,7 @@ sub run_forked { if ($o->{'parent_died'}) { $err_msg .= "parent died\n"; } - if ($o->{'stdout'}) { + if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) { $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n"; } if ($o->{'stderr'}) { @@ -993,7 +1148,7 @@ sub run_forked { return $o; } else { - die("cannot fork: $!") unless defined($pid); + Carp::confess("cannot fork: $!") unless defined($pid); # create new process session for open3 call, # so we hopefully can kill all the subprocesses @@ -1001,7 +1156,7 @@ sub run_forked { # which do setsid theirselves -- can't do anything # with those) - POSIX::setsid() || die("Error running setsid: " . $!); + POSIX::setsid() || Carp::confess("Error running setsid: " . $!); if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') { $opts->{'child_BEGIN'}->(); @@ -1024,6 +1179,11 @@ sub run_forked { }); } elsif (ref($cmd) eq 'CODE') { + # reopen STDOUT and STDERR for child code: + # https://rt.cpan.org/Ticket/Display.html?id=85912 + open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n"); + open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n"); + $child_exit_code = $cmd->({ 'opts' => $opts, 'parent_info' => $parent_info_socket, @@ -1045,6 +1205,7 @@ sub run_forked { $opts->{'child_END'}->(); } + $| = 1; POSIX::_exit $child_exit_code; } } @@ -1123,7 +1284,7 @@ sub run { ### flag indicating if the subcall went ok my $ok; - ### dont look at previous errors: + ### don't look at previous errors: local $?; local $@; local $!; @@ -1207,8 +1368,10 @@ sub _open3_run_win32 { my $outhand = shift; my $errhand = shift; + require Socket; + my $pipe = sub { - socketpair($_[0], $_[1], AF_UNIX, SOCK_STREAM, PF_UNSPEC) + socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) or return undef; shutdown($_[0], 1); # No more writing for reader shutdown($_[1], 0); # No more reading for writer @@ -1258,8 +1421,8 @@ sub _open3_run_win32 { $in_sel->remove($fh); } else { - $obj->( "$buf" ); - } + $obj->( "$buf" ); + } } for my $fh (@$outs) { @@ -1313,7 +1476,7 @@ sub _open3_run { ### whitespace. This sub fixes up such commands so they run properly $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd ); - ### dont stringify @$cmd, so spaces in filenames/paths are + ### don't stringify @$cmd, so spaces in filenames/paths are ### treated properly my $pid = eval { IPC::Open3::open3( @@ -1459,7 +1622,7 @@ sub _open3_run { ### if there's no pipe in the command, append STDIN to the back ### of the command instead. ### XXX seems IPC::Run works it out for itself if you just - ### dont pass STDIN at all. + ### don't pass STDIN at all. # if( $special_chars and $special_chars =~ /\|/ ) { # ### only add STDIN the first time.. # my $i; @@ -1755,7 +1918,7 @@ sub _pp_child_error { } elsif ( $ce & 127 ) { ### some signal - $str = loc( "'%1' died with signal %d, %s coredump\n", + $str = loc( "'%1' died with signal %2, %3 coredump", $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without'); } else { diff --git a/Master/tlpkg/tlperl/lib/IPC/Open3.pm b/Master/tlpkg/tlperl/lib/IPC/Open3.pm index 29612af7c0b..c8620b77ae7 100644 --- a/Master/tlpkg/tlperl/lib/IPC/Open3.pm +++ b/Master/tlpkg/tlperl/lib/IPC/Open3.pm @@ -9,7 +9,7 @@ require Exporter; use Carp; use Symbol qw(gensym qualify); -$VERSION = '1.13'; +$VERSION = '1.16'; @ISA = qw(Exporter); @EXPORT = qw(open3); @@ -57,7 +57,8 @@ as file descriptors. open3() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open3:/>. However, C<exec> failures in the child (such as no such file or permission denied), -are just reported to CHLD_ERR, as it is not possible to trap them. +are just reported to CHLD_ERR under Windows and OS/2, as it is not possible +to trap them. If the child process dies for any reason, the next write to CHLD_IN is likely to generate a SIGPIPE in the parent, which is fatal by default. @@ -98,7 +99,7 @@ C<cat -v> and continually read and write a line from it. =item L<IPC::Open2> -Like Open3 but without STDERR catpure. +Like Open3 but without STDERR capture. =item L<IPC::Run> @@ -184,6 +185,10 @@ sub _open3 { # it's too ugly to use @_ throughout to make perl do it for us # tchrist 5-Mar-00 + # Historically, open3(undef...) has silently worked, so keep + # it working. + splice @_, 0, 1, undef if \$_[0] == \undef; + splice @_, 1, 1, undef if \$_[1] == \undef; unless (eval { $_[0] = gensym unless defined $_[0] && length $_[0]; $_[1] = gensym unless defined $_[1] && length $_[1]; @@ -297,6 +302,7 @@ sub _open3 { if ($bytes_read) { (my $bang, $to_read) = unpack('II', $buf); read($stat_r, my $err = '', $to_read); + waitpid $kidpid, 0; # Reap child which should have exited if ($err) { utf8::decode $err if $] >= 5.008; } else { |