summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IPC/Cmd.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IPC/Cmd.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/IPC/Cmd.pm593
1 files changed, 378 insertions, 215 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 {