From: Chris Williams Date: Sun, 8 Nov 2009 23:27:37 +0000 (+0000) Subject: Update IPC::Cmd to cpan version 0.51_01 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0c2c01a488f0e58de42eaab295cc532ab33511a0;p=p5sagit%2Fp5-mst-13.2.git Update IPC::Cmd to cpan version 0.51_01 Changes for 0.51_01 Sun Nov 8 22:36:33 GMT 2009 ================================================= * Apply patch from Petya Kohts, RT #50398, which adds run_forked() --- diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 41ba287..39c3a58 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -812,7 +812,7 @@ use File::Glob qw(:case); 'IPC::Cmd' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.50.tar.gz', + 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.51_01.tar.gz', 'FILES' => q[cpan/IPC-Cmd], 'CPAN' => 1, 'UPSTREAM' => 'cpan', diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm index 81d85ca..1a5d020 100644 --- a/cpan/IPC-Cmd/lib/IPC/Cmd.pm +++ b/cpan/IPC-Cmd/lib/IPC/Cmd.pm @@ -13,18 +13,30 @@ BEGIN { use Exporter (); use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG - $USE_IPC_RUN $USE_IPC_OPEN3 $WARN + $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN ]; - $VERSION = '0.50'; + $VERSION = '0.51_01'; $VERBOSE = 0; $DEBUG = 0; $WARN = 1; $USE_IPC_RUN = IS_WIN32 && !IS_WIN98; $USE_IPC_OPEN3 = not IS_VMS; + $CAN_USE_RUN_FORKED = 0; + eval { + require POSIX; POSIX->import(); + require IPC::Open3; IPC::Open3->import(); + require IO::Select; IO::Select->import(); + require IO::Handle; IO::Handle->import(); + require Time::HiRes; Time::HiRes->import(); + require FileHandle; FileHandle->import(); + require Socket; Socket->import(); + }; + $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32; + @ISA = qw[Exporter]; - @EXPORT_OK = qw[can_run run QUOTE]; + @EXPORT_OK = qw[can_run run run_forked QUOTE]; } require Carp; @@ -42,7 +54,7 @@ IPC::Cmd - finding and running system commands made easy =head1 SYNOPSIS - use IPC::Cmd qw[can_run run]; + use IPC::Cmd qw[can_run run run_forked]; my $full_path = can_run('wget') or warn 'wget is not installed!'; @@ -160,6 +172,10 @@ sub can_capture_buffer { return; } +=head2 $bool = IPC::Cmd->can_use_run_forked + +Utility function that tells you if C is capable of +providing C on the current platform. =head1 FUNCTIONS @@ -320,6 +336,408 @@ what modules or function calls to use when issuing a command. } } +sub can_use_run_forked { + return $CAN_USE_RUN_FORKED eq "1"; +} + +# give process a chance sending TERM, +# waiting for a while (2 seconds) +# and killing it with KILL +sub kill_gently { + my ($pid) = @_; + + kill(15, $pid); + + my $wait_cycles = 0; + my $child_finished = 0; + + while (!$child_finished && $wait_cycles < 8) { + my $waitpid = waitpid($pid, WNOHANG); + if ($waitpid eq -1) { + $child_finished = 1; + } + + $wait_cycles = $wait_cycles + 1; + usleep(250000); # half a second + } +} + +sub open3_run { + my ($cmd, $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"; + } + + 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{'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, + }, + }; + + 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 $got_sig_child = 0; + $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + + 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") { + kill_gently($pid); + exit; + } + + 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); + $child_finished = 1; + } + } + + usleep(1); + + foreach my $fd ($select->can_read(1/100)) { + my $str = $child_output->{$fd->fileno}; + psSnake::die("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 { + psSnake::die("error during sysread: " . $!); + } + } + } + + waitpid($pid, 0); + + # i've successfully reaped my child, + # let my parent know this + if ($opts->{'parent_info'}) { + my $ps = $opts->{'parent_info'}; + print $ps "reaped $pid\n"; + } + + my $real_exit = $?; + my $exit_value = $real_exit >> 8; + 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 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run_forked( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] ); + +=cut + +sub run_forked { + ### container to store things in + my $self = bless {}, __PACKAGE__; + + if (!can_use_run_forked()) { + Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED"); + return; + } + use Time::HiRes qw/usleep/; + + my ($cmd, $opts) = @_; + + if (!$cmd) { + Carp::carp("run_forked expects command to run"); + return; + } + + $opts = {} unless $opts; + $opts->{'timeout'} = 0 unless $opts->{'timeout'}; + + # sockets to pass child stdout to parent + my $child_stdout_socket; + my $parent_stdout_socket; + + # sockets to pass child stderr to parent + my $child_stderr_socket; + my $parent_stderr_socket; + + # sockets for child -> parent internal communication + my $child_info_socket; + my $parent_info_socket; + + socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) || + die ("socketpair: $!"); + + $child_stdout_socket->autoflush(1); + $parent_stdout_socket->autoflush(1); + $child_stderr_socket->autoflush(1); + $parent_stderr_socket->autoflush(1); + $child_info_socket->autoflush(1); + $parent_info_socket->autoflush(1); + + my $start_time = time(); + + my $pid; + if ($pid = fork) { + + # we are a parent + close($parent_stdout_socket); + close($parent_stderr_socket); + close($parent_info_socket); + + my $child_timedout = 0; + my $flags; + + # prepare sockets to read from child + + $flags = 0; + fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + $flags = 0; + fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + $flags = 0; + fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!"; + $flags |= O_NONBLOCK; + fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!"; + + # print "child $pid started\n"; + + my $child_finished = 0; + my $child_stdout = ""; + my $child_stderr = ""; + my $child_exit_code = 0; + + my $got_sig_child = 0; + $SIG{'CHLD'} = sub { $got_sig_child = time(); }; + + my $child_child_pid; + + while (!$child_finished) { + # user specified timeout + if ($opts->{'timeout'}) { + if (time() - $start_time > $opts->{'timeout'}) { + kill (-9, $pid); + $child_timedout = 1; + } + } + + # give OS 10 seconds for correct return of waitpid, + # kill process after that and finish wait loop; + # shouldn't ever happen -- remove this code? + if ($got_sig_child) { + if (time() - $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; + } + } + + my $waitpid = waitpid($pid, WNOHANG); + + # child finished, catch it's exit status + if ($waitpid ne 0 && $waitpid ne -1) { + $child_exit_code = $? >> 8; + } + + if ($waitpid eq -1) { + $child_finished = 1; + next; + } + + # child -> parent simple internal communication protocol + while (my $l = <$child_info_socket>) { + if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) { + $child_child_pid = $1; + $l = $2; + } + if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) { + $child_child_pid = undef; + $l = $2; + } + } + + while (my $l = <$child_stdout_socket>) { + $child_stdout .= $l; + + if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') { + $opts->{'stdout_handler'}->($l); + } + } + while (my $l = <$child_stderr_socket>) { + $child_stderr .= $l; + + if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') { + $opts->{'stderr_handler'}->($l); + } + } + + usleep(1); + } + + # $child_pid_pid is not defined in two cases: + # * when our child was killed before + # it had chance to tell us the pid + # of the child it spawned. we can do + # nothing in this case :( + # * our child successfully reaped its child, + # we have nothing left to do in this case + # + # defined $child_pid_pid means child's child + # has not died but nobody is waiting for it, + # killing it brutaly. + # + if ($child_child_pid) { + kill_gently($child_child_pid); + } + + # print "child $pid finished\n"; + + close($child_stdout_socket); + close($child_stderr_socket); + close($child_info_socket); + + my $o = { + 'stdout' => $child_stdout, + 'stderr' => $child_stderr, + 'timeout' => $child_timedout ? $opts->{'timeout'} : 0, + 'exit_code' => $child_exit_code, + }; + + my $err_msg = ""; + if ($o->{'exit_code'}) { + $err_msg .= "exited with code [$o->{'exit_code'}]\n"; + } + if ($o->{'timeout'}) { + $err_msg .= "ran more than [$o->{'timeout'}] seconds\n"; + } + if ($o->{'stdout'}) { + $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n"; + } + if ($o->{'stderr'}) { + $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n"; + } + $o->{'err_msg'} = $err_msg; + + return $o; + } + else { + die("cannot fork: $!") unless defined($pid); + + # create new process session for open3 call, + # so we hopefully can kill all the subprocesses + # which might be spawned in it (except for those + # which do setsid theirselves -- can't do anything + # with those) + + POSIX::setsid() || die("Error running setsid: " . $!); + + close($child_stdout_socket); + close($child_stderr_socket); + close($child_info_socket); + + my $child_exit_code = open3_run($cmd, { + 'parent_info' => $parent_info_socket, + 'parent_stdout' => $parent_stdout_socket, + 'parent_stderr' => $parent_stderr_socket, + 'child_stdin' => $opts->{'child_stdin'}, + }); + + close($parent_stdout_socket); + close($parent_stderr_socket); + close($parent_info_socket); + + exit $child_exit_code; + } +} + sub run { ### container to store things in my $self = bless {}, __PACKAGE__; diff --git a/cpan/IPC-Cmd/t/01_IPC-Cmd.t b/cpan/IPC-Cmd/t/01_IPC-Cmd.t index eca515e..0773479 100644 --- a/cpan/IPC-Cmd/t/01_IPC-Cmd.t +++ b/cpan/IPC-Cmd/t/01_IPC-Cmd.t @@ -9,8 +9,8 @@ use Test::More 'no_plan'; my $Class = 'IPC::Cmd'; my $AClass = $Class . '::TimeOut'; -my @Funcs = qw[run can_run QUOTE]; -my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer]; +my @Funcs = qw[run can_run QUOTE run_forked]; +my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked]; my $IsWin32 = $^O eq 'MSWin32'; my $Verbose = @ARGV ? 1 : 0; @@ -155,6 +155,23 @@ push @Prefs, [ 0, 0 ], [ 0, 0 ]; } } } + +unless ( IPC::Cmd->can_use_run_forked ) { + ok(1, "run_forked not available on this platform"); + exit; +} + +{ + my $cmd = "echo out ; echo err >&2 ; sleep 4"; + my $r = run_forked($cmd, {'timeout' => 1}); + + ok(ref($r) eq 'HASH', "executed: $cmd"); + ok($r->{'timeout'} eq 1, "timed out"); + ok($r->{'stdout'}, "stdout: " . $r->{'stdout'}); + ok($r->{'stderr'}, "stderr: " . $r->{'stderr'}); +} + + __END__ ### special call to check that output is interleaved properly { my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ]; @@ -219,6 +236,4 @@ __END__ like( $err,qr/^$AClass/," Error '$err' mentions $AClass" ); } } - -