Update IPC-Cmd to CPAN version 0.92

  [DELTA]

0.92 Wed Jan 22 19:57:27 GMT 2014

  Test fixes:
  * Use File::Temp in run_forked tests (hugmeir)

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 1561083..010325d 100755 (executable)
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -637,7 +637,7 @@ use File::Glob qw(:case);
     },
 
     'IPC::Cmd' => {
-        'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.90.tar.gz',
+        'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.92.tar.gz',
         'FILES'        => q[cpan/IPC-Cmd],
     },
 

diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
index 62ab7e3..6a82bdf 100644 (file)
--- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm
+++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm
@@ -18,7 +18,7 @@ BEGIN {
                         $HAVE_MONOTONIC
                     ];
 
-    $VERSION        = '0.90';
+    $VERSION        = '0.92';
     $VERBOSE        = 0;
     $DEBUG          = 0;
     $WARN           = 1;
@@ -506,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;
+        }
 
-    Time::HiRes::usleep(1);
+        if ($waitpid eq -1) {
+          $child_finished = 1;
+        }
 
-    foreach my $fd ($select->can_read(1/100)) {
-      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'});
+        my $ready_fds = [];
+        push @{$ready_fds}, $select->can_read(1/100);
 
-      if ($count) {
-        if ($str->{'parent_socket'}) {
-          my $ph = $str->{'parent_socket'};
-          print $ph $data;
-        }
-        else {
-          $str->{'scalar_buffer'} .= $data;
+        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) {
+                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 {
-        Carp::confess("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} );

diff --git a/cpan/IPC-Cmd/t/03_run-forked.t b/cpan/IPC-Cmd/t/03_run-forked.t
index 499b7ad..5425334 100644 (file)
--- a/cpan/IPC-Cmd/t/03_run-forked.t
+++ b/cpan/IPC-Cmd/t/03_run-forked.t
@@ -7,6 +7,7 @@ use warnings;
 use lib qw[../lib];
 use Test::More 'no_plan';
 use Data::Dumper;
+use File::Temp qw(tempfile);
 
 use_ok("IPC::Cmd", "run_forked");
 
@@ -72,10 +73,8 @@ 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 ($fh, $filename) = tempfile();
 my $one_line = "in Montenegro with Katyusha\n";
-my $fh;
-open($fh, ">$filename");
 for (my $i = 0; $i < 10240; $i++) {
   print $fh $one_line;
 }