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

2 files changed, 154 insertions, 42 deletions

diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index 10b4ace9a0..e41095ffd9 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 eedbad84e3..633f7ccd98 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);