From 7d88c327edd82b1ca4f092f56f1a171b72d4bdcc Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Mon, 4 Nov 2013 15:46:12 +0000 Subject: [PATCH] Update IPC-Cmd to CPAN release 0.86 [DELTA] 0.86 Mon Nov 4 14:09:42 GMT 2013 ====================================== Bug fixes: * run_forked: workaround absent CLOCK_MONOTONIC on OSX (Petya Kohts) * RT#89770 Patch to fix error reporting if command killed by signal (Ed Avis) * Make the false test more forgiving, for Solaris and other SVR* (bingos) 0.85_02 Thu Oct 10 13:59:34 BST 2013 ====================================== Bug Fixes: * run_forked: incomplete output more than buffer size 0.85_01 Thu Sep 5 20:30:51 BST 2013 ====================================== Enhancements: * run_forked() now uses Time::HiRes and Carp --- Porting/Maintainers.pl | 7 +- cpan/IPC-Cmd/lib/IPC/Cmd.pm | 158 +++++++++++++++++++++++++++++++---------- cpan/IPC-Cmd/t/03_run-forked.t | 38 ++++++++-- 3 files changed, 155 insertions(+), 48 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 618ccf0..c151381 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -636,13 +636,8 @@ use File::Glob qw(:case); }, 'IPC::Cmd' => { - 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.84.tar.gz', + 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.86.tar.gz', 'FILES' => q[cpan/IPC-Cmd], - # Waiting to be merged upstream: no ticket, but customized by maintainer - 'CUSTOMIZED' => [ - 'lib/IPC/Cmd.pm', - 't/03_run-forked.t', - ], }, 'IPC::SysV' => { diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm index 10b4ace..e41095f 100644 --- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm +++ b/cpan/IPC-Cmd/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.84_01'; + $VERSION = '0.86'; $VERBOSE = 0; $DEBUG = 0; $WARN = 1; @@ -38,6 +39,16 @@ BEGIN { }; $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]; } @@ -352,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 { @@ -359,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}; @@ -419,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 } @@ -556,7 +621,7 @@ sub open3_run { 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'}); @@ -575,7 +640,7 @@ sub open3_run { $fd->close(); } else { - psSnake::die("error during sysread: " . $!); + Carp::confess("error during sysread: " . $!); } } } @@ -751,11 +816,11 @@ sub run_forked { 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); @@ -764,7 +829,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) { @@ -779,19 +844,19 @@ 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"; @@ -828,27 +893,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', @@ -858,13 +926,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', @@ -878,7 +946,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; @@ -903,12 +971,17 @@ sub run_forked { 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'}); @@ -932,7 +1005,7 @@ sub run_forked { } } 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 @@ -955,7 +1028,7 @@ sub run_forked { # 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') { @@ -978,6 +1051,15 @@ sub run_forked { $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); @@ -1044,7 +1126,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'}) { @@ -1065,7 +1147,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 @@ -1073,7 +1155,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'}->(); @@ -1098,8 +1180,8 @@ 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 || 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, @@ -1835,7 +1917,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/cpan/IPC-Cmd/t/03_run-forked.t b/cpan/IPC-Cmd/t/03_run-forked.t index eedbad8..633f7cc 100644 --- a/cpan/IPC-Cmd/t/03_run-forked.t +++ b/cpan/IPC-Cmd/t/03_run-forked.t @@ -22,9 +22,10 @@ my $true = IPC::Cmd::can_run('true'); 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; } @@ -33,13 +34,13 @@ my $r; $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 @@ -62,3 +63,32 @@ ok($retval->{"stdout"} =~ /blahblah/, "https://rt.cpan.org/Ticket/Display.html?i 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); -- 2.7.4