multithreading - 线程内的 Perl 设置超时失败 : 'Alarm clock'

Question

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

use strict; use warnings;                                                                                                                                                                                                                                             
require threads;                                                                                                                                                                                                                                                      
require threads::shared;                                                                                                                                                                                                                                              

my $t = threads->create( sub {                                                                                                                                                                                                                                        

    eval {                                                                                                                                                                                                                                                            
        $SIG{ALRM} = sub { die "alarm\n" };                                                                                                                                                                                                                           
        alarm 2;                                                                                                                                                                                                                                                      
        main();                                                                                                                                                                                                                                                       
        alarm 0;                                                                                                                                                                                                                                                      
    };                                                                                                                                                                                                                                                                
    if ($@){                                                                                                                                                                                                                                                          
        die $@ unless $@ eq "alarm\n";                                                                                                                                                                                                                                
        print "timed out\n";                                                                                                                                                                                                                                          
    }                                                                                                                                                                                                                                                                 
                 }                                                                                                                                                                                                                                                    
    );                                                                                                                                                                                                                                                                

my @r = $t->join;                                                                                                                                                                                                                                                     
print "done\n";                                                                                                                                                                                                                                                       

sub main {                                                                                                                                                                                                                                                            
    sleep 3;                                                                                                                                                                                                                                                          
}                                                                                                                                                                                                                                                                     

This post建议在 threads 库中调用 alarm 时没有信号处理程序。 Another post关于这个问题，答案建议使用fork 和waitpid，但我真的很想使用threads。 Another post声称想出了一个解决方案，但这仍然给我 Alarm clock 错误。我试图在 if ($@) 中捕获 Alarm clock，但没有成功。知道我如何才能完成这项工作吗？

Answer 1

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

1. 信号被发送到进程，而不是线程。
2. 如果两个线程要使用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 ，等待)。简单的解决方案:向调用 threads->kill 后立即不执行任何操作的处理程序发送真实信号。也许我应该编写一个基于实际 SIGALRM 的解决方案。