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.84_01';
+ $VERSION = '0.86';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
};
$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];
}
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 {
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};
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
}
foreach my $fd ($select->can_read(1/100)) {
my $str = $child_output->{$fd->fileno};
- psSnake::die("child stream not found: $fd") unless $str;
+ Carp::confess("child stream not found: $fd") unless $str;
my $data;
my $count = $fd->sysread($data, $str->{'block_size'});
$fd->close();
}
else {
- psSnake::die("error during sysread: " . $!);
+ Carp::confess("error during sysread: " . $!);
}
}
}
my $parent_info_socket;
socketpair($child_stdout_socket, $parent_stdout_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- die ("socketpair: $!");
+ Carp::confess ("socketpair: $!");
socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- die ("socketpair: $!");
+ Carp::confess ("socketpair: $!");
socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
- die ("socketpair: $!");
+ Carp::confess ("socketpair: $!");
$child_stdout_socket->autoflush(1);
$parent_stdout_socket->autoflush(1);
$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) {
# 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_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',
$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',
# 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;
if ($waitpid eq -1) {
$child_finished = 1;
- next;
}
- foreach my $fd ($select->can_read(1/100)) {
+ 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};
- die("child stream not found: $fd") unless $str;
+ Carp::confess("child stream not found: $fd") unless $str;
my $data = "";
my $count = $fd->sysread($data, $str->{'block_size'});
}
}
else {
- die("error during sysread on [$fd]: " . $!);
+ Carp::confess("error during sysread on [$fd]: " . $!);
}
# $data contains only full lines (or last line if it was unfinished read
# we don't expect any other data in info socket, so it's
# some strange violation of protocol, better know about this
if ($data) {
- die("info protocol violation: [$data]");
+ Carp::confess("info protocol violation: [$data]");
}
}
if ($str->{'protocol'} eq 'stdout') {
$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);
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'}) {
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
# 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'}->();
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 || die("Unable to reopen STDOUT: $!\n");
- open STDERR, '>&', $parent_stderr_socket || die("Unable to reopen STDERR: $!\n");
+ 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,
} 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 {
my $false = IPC::Cmd::can_run('false');
my $echo = IPC::Cmd::can_run('echo');
my $sleep = IPC::Cmd::can_run('sleep');
+my $cat = IPC::Cmd::can_run('cat');
-unless ( $true and $false and $echo and $sleep ) {
- ok(1, 'Either "true" or "false" "echo" or "sleep" is missing on this platform');
+unless ( $true and $false and $echo and $sleep and $cat ) {
+ ok(1, 'Either "true" or "false" "echo" or "sleep" or "cat" is missing on this platform');
exit;
}
$r = run_forked($true);
ok($r->{'exit_code'} eq '0', "$true returns 0");
$r = run_forked($false);
-ok($r->{'exit_code'} ne '0', "$false returns 1");
+ok($r->{'exit_code'} ne '0', "$false returns not 0");
$r = run_forked([$echo, "test"]);
ok($r->{'stdout'} =~ /test/, "arrayref cmd: https://rt.cpan.org/Ticket/Display.html?id=70530");
$r = run_forked("$sleep 5", {'timeout' => 2});
-ok($r->{'timeout'}, "[sleep 5] runs longer than 2 seconds");
+ok($r->{'timeout'}, "[$sleep 5] runs longer than 2 seconds");
# https://rt.cpan.org/Ticket/Display.html?id=85912
ok($retval->{"stdout"} =~ /Hello sailor/, "https://rt.cpan.org/Ticket/Display.html?id=85912 stdout 2");
ok($retval->{"stderr"} =~ /Boo/, "https://rt.cpan.org/Ticket/Display.html?id=85912 stderr 1");
ok($retval->{"stderr"} =~ /eek/, "https://rt.cpan.org/Ticket/Display.html?id=85912 stderr 2");
+
+$r = run_forked("$echo yes i know this is the way", {'discard_output' => 1});
+ok($r->{'stdout'} eq '', "discard_output stdout");
+ok($r->{'stderr'} eq '', "discard_output stderr");
+ok($r->{'merged'} eq '', "discard_output merged");
+ok($r->{'err_msg'} eq '', "discard_output err_msg");
+
+my $filename = "/tmp/03_run_forked.t.$$";
+my $one_line = "in Montenegro with Katyusha\n";
+my $fh;
+open($fh, ">$filename");
+for (my $i = 0; $i < 10240; $i++) {
+ print $fh $one_line;
+}
+close($fh);
+
+for (my $i = 0; $i < 100; $i++) {
+ my $f_ipc_cmd = IPC::Cmd::run_forked("$cat $filename");
+ my $f_backticks = `$cat $filename`;
+ if ($f_ipc_cmd->{'stdout'} ne $f_backticks) {
+ fail ("reading $filename: run_forked output length [" . length($f_ipc_cmd->{'stdout'}) . "], backticks output length [" . length ($f_backticks) . "]");
+ #print Data::Dumper::Dumper($f_ipc_cmd);
+ die;
+ }
+ else {
+ pass ("$i: reading $filename");
+ }
+}
+unlink($filename);
projects / platform / upstream / perl.git / commitdiff