From e667e1e196e99f0ec14c136cc246c2b213eadd06 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Tue, 13 Jul 2010 11:56:15 +0100 Subject: [PATCH] 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 --- Porting/Maintainers.pl | 2 +- cpan/IPC-Cmd/lib/IPC/Cmd.pm | 141 ++++++++++++++++++++++++++++++++++++++------ 2 files changed, 123 insertions(+), 20 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 95a15ec..240b6c8 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -754,7 +754,7 @@ use File::Glob qw(:case); 'IPC::Cmd' => { 'MAINTAINER' => 'kane', - 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.58.tar.gz', + 'DISTRIBUTION' => 'BINGOS/IPC-Cmd-0.60.tar.gz', 'FILES' => q[cpan/IPC-Cmd], 'UPSTREAM' => 'cpan', }, diff --git a/cpan/IPC-Cmd/lib/IPC/Cmd.pm b/cpan/IPC-Cmd/lib/IPC/Cmd.pm index 80ecbe1..8c7a87e 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 = ''; -- 2.7.4