Update IPC-Cmd to CPAN version 0.60

  [DELTA]

  Changes for 0.60    Mon Jul  5 09:04:54 BST 2010
  =================================================
  * Corrected spelling mistakes in POD, spotted by H.Merijn Brand
  * Apply a patch from Burak Gursoy RT #58886, which fixes paths
    on MSWin32
  * Apply patch from Petya Kohts, RT #50398, which allows more
    flexible configuration of run_forked and its children

1 files changed, 122 insertions, 19 deletions

diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index 80ecbe12d9..8c7a87ef70 100644
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
@@ -16,7 +16,7 @@ BEGIN {
                         $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
                     ];
 
-    $VERSION        = '0.58';
+    $VERSION        = '0.60';
     $VERBOSE        = 0;
     $DEBUG          = 0;
     $WARN           = 1;
@@ -32,6 +32,7 @@ BEGIN {
         require FileHandle; FileHandle->import();
         require Socket; Socket->import();
         require Time::HiRes; Time::HiRes->import();
+        require Win32 if IS_WIN32;
     };
     $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
 
@@ -216,8 +217,9 @@ sub can_run {
         for my $dir (
             (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
             File::Spec->curdir
-        ) {           
-            my $abs = File::Spec->catfile($dir, $command);
+        ) {
+            next if ! $dir || ! -d $dir;
+            my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
             return $abs if $abs = MM->maybe_command($abs);
         }
     }
@@ -340,29 +342,89 @@ sub can_use_run_forked {
     return $CAN_USE_RUN_FORKED eq "1";
 }
 
+# incompatible with POSIX::SigAction
+#
+sub install_layered_signal {
+  my ($s, $handler_code) = @_;
+
+  my %available_signals = map {$_ => 1} keys %SIG;
+
+  die("install_layered_signal got nonexistent signal name [$s]")
+    unless defined($available_signals{$s});
+  die("install_layered_signal expects coderef")
+    if !ref($handler_code) || ref($handler_code) ne 'CODE';
+
+  my $previous_handler = $SIG{$s};
+
+  my $sig_handler = sub {
+    my ($called_sig_name, @sig_param) = @_;
+    
+    # $s is a closure refering to real signal name
+    # for which this handler is being installed.
+    # it is used to distinguish between
+    # real signal handlers and aliased signal handlers
+    my $signal_name = $s;
+
+    # $called_sig_name is a signal name which
+    # was passed to this signal handler;
+    # it doesn't equal $signal_name in case
+    # some signal handlers in %SIG point
+    # to other signal handler (CHLD and CLD,
+    # ABRT and IOT)
+    #
+    # initial signal handler for aliased signal
+    # calles some other signal handler which
+    # should not execute the same handler_code again
+    if ($called_sig_name eq $signal_name) {
+      $handler_code->($signal_name);
+    }
+
+    # run original signal handler if any (including aliased)
+    #
+    if (ref($previous_handler)) {
+      $previous_handler->($called_sig_name, @sig_param);
+    }
+  };
+
+  $SIG{$s} = $sig_handler;
+}
+
 # give process a chance sending TERM,
 # waiting for a while (2 seconds)
 # and killing it with KILL
 sub kill_gently {
-  my ($pid) = @_;
+  my ($pid, $opts) = @_;
   
-  kill(15, $pid);
+  $opts = {} unless $opts;
+  $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
+  $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
+  $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
+  
+  if ($opts->{'first_kill_type'} eq 'just_process') {
+    kill(15, $pid);
+  }
+  elsif ($opts->{'first_kill_type'} eq 'process_group') {
+    kill(-15, $pid);
+  }
   
-  my $wait_cycles = 0;
   my $child_finished = 0;
+  my $wait_start_time = time();
 
-  while (!$child_finished && $wait_cycles < 8) {
+  while (!$child_finished && $wait_start_time + $opts->{'wait_time'} > time()) {
     my $waitpid = waitpid($pid, WNOHANG);
     if ($waitpid eq -1) {
       $child_finished = 1;
     }
-
-    $wait_cycles = $wait_cycles + 1;
-    Time::HiRes::usleep(250000); # half a second
+    Time::HiRes::usleep(250000); # quarter of a second
   }
 
   if (!$child_finished) {
-    kill(9, $pid);
+    if ($opts->{'final_kill_type'} eq 'just_process') {
+      kill(9, $pid);
+    }
+    elsif ($opts->{'final_kill_type'} eq 'process_group') {
+      kill(-9, $pid);
+    }
   }
 }
 
@@ -454,9 +516,16 @@ sub open3_run {
     }
 
     if ($got_sig_child) {
-      if (time() - $got_sig_child > 10) {
-        print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
-        kill (-9, $pid);
+      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;
       }
     }
@@ -491,8 +560,9 @@ sub open3_run {
 
   waitpid($pid, 0);
 
-  # i've successfully reaped my child,
-  # let my parent know this
+  # since we've successfully reaped the child,
+  # let our parent know about this.
+  #
   if ($opts->{'parent_info'}) {
     my $ps = $opts->{'parent_info'};
     print $ps "reaped $pid\n";
@@ -629,6 +699,7 @@ sub run_forked {
 
     $opts = {} unless $opts;
     $opts->{'timeout'} = 0 unless $opts->{'timeout'};
+    $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
 
     # sockets to pass child stdout to parent
     my $child_stdout_socket;
@@ -696,8 +767,13 @@ sub run_forked {
       my $parent_died = 0;
 
       my $got_sig_child = 0;
+      my $got_sig_quit = 0;
       $SIG{'CHLD'} = sub { $got_sig_child = time(); };
 
+      if ($opts->{'terminate_on_signal'}) {
+        install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
+      }
+
       my $child_child_pid;
 
       while (!$child_finished) {
@@ -737,6 +813,15 @@ sub run_forked {
           }
         }
 
+        if ($got_sig_quit) {
+          kill_gently ($pid, {
+            'first_kill_type' => 'process_group',
+            'final_kill_type' => 'process_group',
+            'wait_time' => $opts->{'terminate_wait_time'}
+            });
+          $child_finished = 1;
+        }
+
         my $waitpid = waitpid($pid, WNOHANG);
 
         # child finished, catch it's exit status
@@ -762,7 +847,7 @@ sub run_forked {
         }
 
         while (my $l = <$child_stdout_socket>) {
-          if (!$opts->{discard_output}) {
+          if (!$opts->{'discard_output'}) {
             $child_stdout .= $l;
             $child_merged .= $l;
           }
@@ -772,7 +857,7 @@ sub run_forked {
           }
         }
         while (my $l = <$child_stderr_socket>) {
-          if (!$opts->{discard_output}) {
+          if (!$opts->{'discard_output'}) {
             $child_stderr .= $l;
             $child_merged .= $l;
           }
@@ -800,6 +885,23 @@ sub run_forked {
         kill_gently($child_child_pid);
       }
 
+      # in case there are forks in child which
+      # do not forward or process signals (TERM) correctly
+      # kill whole child process group, effectively trying
+      # not to return with some children or their parts still running
+      #
+      # to be more accurate -- we need to be sure
+      # that this is process group created by our child
+      # (and not some other process group with the same pgid,
+      # created just after death of our child) -- fortunately
+      # this might happen only when process group ids
+      # are reused quickly (there are lots of processes
+      # spawning new process groups for example)
+      #
+      if ($opts->{'clean_up_children'}) {
+        kill(-9, $pid);
+      }
+
   #    print "child $pid finished\n";
 
       close($child_stdout_socket);
@@ -812,7 +914,8 @@ sub run_forked {
         'merged' => $child_merged,
         'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
         'exit_code' => $child_exit_code,
-       'parent_died' => $parent_died,
+        'parent_died' => $parent_died,
+        'child_pgid' => $pid,
         };
 
       my $err_msg = '';