线程内的 Perl 设置超时失败：'Alarm clock'

Question

我有一个线程应用程序，想为线程设置超时。Peldoc建议使用eval - die对，捕获ALRM信号。但是，如果线程产生错误Alarm clock:

，则会失败。

use strict; use warnings;                                                                                                                                                                                                                                             
require threads;                                                                                                                                                                                                                                                      
require threads::shared;                                                                                                                                                                                                                                              
my $t = threads->create( sub {                                                                                                                                                                                                                                        
    eval {                                                                                                                                                                                                                                                            
        $SIG{ALRM} = sub { die "alarmn" };                                                                                                                                                                                                                           
        alarm 2;                                                                                                                                                                                                                                                      
        main();                                                                                                                                                                                                                                                       
        alarm 0;                                                                                                                                                                                                                                                      
    };                                                                                                                                                                                                                                                                
    if ($@){                                                                                                                                                                                                                                                          
        die $@ unless $@ eq "alarmn";                                                                                                                                                                                                                                
        print "timed outn";                                                                                                                                                                                                                                          
    }                                                                                                                                                                                                                                                                 
                 }                                                                                                                                                                                                                                                    
    );                                                                                                                                                                                                                                                                
my @r = $t->join;                                                                                                                                                                                                                                                     
print "donen";                                                                                                                                                                                                                                                       
sub main {                                                                                                                                                                                                                                                            
    sleep 3;                                                                                                                                                                                                                                                          
}                                                                                                                                                                                                                                                                     

这篇文章建议在threads库中调用alarm而不使用信号处理程序。另一个帖子是关于这个问题的，答案建议使用fork和waitpid，但我真的很想使用threads。另一个帖子声称提出了一个解决方案，但这仍然给我Alarm clock错误。我试图在if ($@)中抓住Alarm clock，但没有成功。知道我该怎么做吗?

Answer 1

在线程中使用alarm的整个想法是有问题的。

1. 信号被发送给进程，而不是线程。
如果两个线程都想使用alarm怎么办?

你必须实现你自己的系统。下面是一个通解的尝试:

package Threads::Alarm;
use strict;
use warnings;
use threads;
use threads::shared;
use Exporter qw( import );

our @EXPORT_OK = qw( alarm thread_alarm );

# A list of "$time:$tid" strings sorted by ascending time.
my @alarms :shared;
sub thread_alarm {
   my ($wait) = @_;
   my $tid  = threads->tid();
   lock @alarms;
   # Cancel existing alarm for this thread, if any.
   for my $i (0..$#alarms) {
      if ((split(/:/, $alarms[$i]))[1] == $tid) {
         splice(@alarms, $i, 1);
         last;
      }
   }
   # Create an alarm
   if ($wait) {
      my $when = time() + $wait;
      # A binary search would be better.
      my $i;
      for ($i=0; $i<@alarms; ++$i) {
         last if $when < (split(/:/, $alarms[$i]))[0];
      }
      splice(@alarms, $i, 0, "$when:$tid");
   }
   # Notify others of change to @alarms.
   cond_broadcast(@alarms);
}

{
   no warnings 'once';
   *alarm = &thread_alarm;
}

threads->create(sub {
   while (1) {
      my $thread;
      {
         lock @alarms;
         while (1) {
            # Wait for an alarm request to come in.
            cond_wait(@alarms) while !@alarms;
            # Grab the soonest alarm.
            my ($when, $tid) = split(/:/, $alarms[0]);
            # Check if the thread still exists.
            my $thread = threads->object($tid)
               or last;
            # Wait for the @alarms to change or for the alarm time.    
            last if !cond_timedwait(@alarms, $when);
         }
         # Before releasing the lock, remove the alarm we're about to raise.
         shift(@alarms);
         # Notify others of change to @alarms.
         # Doesn't actually do anything at this time.
         cond_broadcast(@alarms);
      }
      $thread->kill('ALRM') if $thread;
   }
})->detach();

1;

完全未经测试。好吧，我确保它可以编译，但仅此而已。

注意threads->kill没有发送一个真正的信号(因为那些是发送给进程的，而不是线程的)，所以操作系统不会中断任何操作(例如sleep, wait)。简单的解决方案:在调用threads->kill之后，向处理器发送一个真实的信号，处理器什么都不做。也许我应该写一个基于实际SIGALRM的解决方案。