$USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
];
- $VERSION = '0.58';
+ $VERSION = '0.60';
$VERBOSE = 0;
$DEBUG = 0;
$WARN = 1;
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;
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);
}
}
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);
+ }
}
}
}
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;
}
}
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";
$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;
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) {
}
}
+ 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
}
while (my $l = <$child_stdout_socket>) {
- if (!$opts->{discard_output}) {
+ if (!$opts->{'discard_output'}) {
$child_stdout .= $l;
$child_merged .= $l;
}
}
}
while (my $l = <$child_stderr_socket>) {
- if (!$opts->{discard_output}) {
+ if (!$opts->{'discard_output'}) {
$child_stderr .= $l;
$child_merged .= $l;
}
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);
'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 = '';
projects / platform / upstream / perl.git / commitdiff