From 9c213c250ec5aeaa30aa3d4c8ff3a1ccb02330a9 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Wed, 22 Jan 2014 20:28:25 +0000 Subject: [PATCH] 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) --- Porting/Maintainers.pl | 2 +- cpan/IPC-Cmd/lib/IPC/Cmd.pm | 289 +++++++++++++++++++++-------------------- cpan/IPC-Cmd/t/03_run-forked.t | 5 +- 3 files changed, 148 insertions(+), 148 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 1561083..010325d 100755 --- 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 --- 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 --- 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; } -- 2.7.4