Perl 在线程内设置超时失败：'闹钟'

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、wait）。简单的解决方案：在调用 threads->kill 后向处理程序发送一个真正的信号，该处理程序什么都不做。也许我应该编写一个基于实际 SIGALRM 的解决方案。