如何在不使分叉进程超时的情况下杀死在perl脚本中花费太长时间的分叉进程？

Question

I've been using the following template for all of my forking/processes needs when it comes to processing "things" in parallel. It basically loops through everything I need to process, X number of entries at a time, and time's out any entries that take too long:

my $num_procs = 0;
foreach my $entry (@entries) {
  $num_procs++;
  if($num_procs == $MAX_PROCS) {
    wait();
    $num_procs--;
  }
  my $pid = fork();
  if($pid == 0) {
    process($entry);
  } 
}
for (; $num_procs>0; $num_procs--) {
  wait();
}

The "process" routine has the following template which times out the process:

my $TIMEOUT_IN_SECONDS = 15;
eval {
  local $SIG{ALRM} = sub { die "alarm" };
  alarm($TIMEOUT_IN_SECONDS);       

  # do something

  alarm(0);
};
if ($@) {
  # do something about the timeout
}   

I've now come across an issue where this no longer works because the child is unable to time itself out. (I think this is due to an I/O blocking issue with NFS) The only way around this, I'm thinking, is for the parent itself to kill -9 the child.

Is there a way to modify my code to do this?

Answer 1

Whenever alarm can be flaky, it is a good use case for the poor man's alarm :

my $pid = fork();
if ($pid == 0) {
    ...  # child code
    exit;
}
if (fork() == 0) {
    my $time = 15;
    exec($^X, "-e", "sleep 1,kill(0,$pid)||exit for 1..$time;kill -9,$pid");
    die; # shouldn't get here 
}

The first fork fires off your child process. The second fork is for running a process to kill the first process after $time seconds.