home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / Mail / SpamAssassin / Timeout.pm < prev    next >
Text File  |  2006-11-29  |  6KB  |  225 lines
  1. # <@LICENSE>
  2. # Licensed to the Apache Software Foundation (ASF) under one or more
  3. # contributor license agreements.  See the NOTICE file distributed with
  4. # this work for additional information regarding copyright ownership.
  5. # The ASF licenses this file to you under the Apache License, Version 2.0
  6. # (the "License"); you may not use this file except in compliance with
  7. # the License.  You may obtain a copy of the License at:
  8. # 
  9. #     http://www.apache.org/licenses/LICENSE-2.0
  10. # 
  11. # Unless required by applicable law or agreed to in writing, software
  12. # distributed under the License is distributed on an "AS IS" BASIS,
  13. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  14. # See the License for the specific language governing permissions and
  15. # limitations under the License.
  16. # </@LICENSE>
  17.  
  18. =head1 NAME
  19.  
  20. Mail::SpamAssassin::Timeout - safe, reliable timeouts in perl
  21.  
  22. =head1 SYNOPSIS
  23.  
  24.     # non-timeout code...
  25.  
  26.     my $t = Mail::SpamAssassin::Timeout->new({ secs => 5 });
  27.     
  28.     $t->run(sub {
  29.         # code to run with a 5-second timeout...
  30.     });
  31.  
  32.     if ($t->timed_out()) {
  33.         # do something...
  34.     }
  35.  
  36.     # more non-timeout code...
  37.  
  38. =head1 DESCRIPTION
  39.  
  40. This module provides a safe, reliable and clean API to provide
  41. C<alarm(2)>-based timeouts for perl code.
  42.  
  43. Note that C<$SIG{ALRM}> is used to provide the timeout, so this will not
  44. interrupt out-of-control regular expression matches.
  45.  
  46. Nested timeouts are supported.
  47.  
  48. =head1 PUBLIC METHODS
  49.  
  50. =over 4
  51.  
  52. =cut
  53.  
  54. package Mail::SpamAssassin::Timeout;
  55.  
  56. use strict;
  57. use warnings;
  58. use bytes;
  59.  
  60. use vars qw{
  61.   @ISA
  62. };
  63.  
  64. @ISA = qw();
  65.  
  66. ###########################################################################
  67.  
  68. =item my $t = Mail::SpamAssassin::Timeout->new({ ... options ... });
  69.  
  70. Constructor.  Options include:
  71.  
  72. =over 4
  73.  
  74. =item secs => $seconds
  75.  
  76. timeout, in seconds.  Optional; if not specified, no timeouts will be applied.
  77.  
  78. =back
  79.  
  80. =cut
  81.  
  82. sub new {
  83.   my ($class, $opts) = @_;
  84.   $class = ref($class) || $class;
  85.   my %selfval = $opts ? %{$opts} : ();
  86.   my $self = \%selfval;
  87.  
  88.   bless ($self, $class);
  89.   $self;
  90. }
  91.  
  92. ###########################################################################
  93.  
  94. =item $t->run($coderef)
  95.  
  96. Run a code reference within the currently-defined timeout.
  97.  
  98. The timeout is as defined by the B<secs> parameter to the constructor.
  99.  
  100. Returns whatever the subroutine returns, or C<undef> on timeout.
  101. If the timer times out, C<$t-<gt>timed_out()> will return C<1>.
  102.  
  103. Time elapsed is not cumulative; multiple runs of C<run> will restart the
  104. timeout from scratch.
  105.  
  106. =item $t->run_and_catch($coderef)
  107.  
  108. Run a code reference, as per C<$t-<gt>run()>, but also catching any
  109. C<die()> calls within the code reference.
  110.  
  111. Returns C<undef> if no C<die()> call was executed and C<$@> was unset, or the
  112. value of C<$@> if it was set.  (The timeout event doesn't count as a C<die()>.)
  113.  
  114. =cut
  115.  
  116. sub run { $_[0]->_run($_[1], 0); }
  117.  
  118. sub run_and_catch { $_[0]->_run($_[1], 1); }
  119.  
  120. sub _run {      # private
  121.   my ($self, $sub, $and_catch) = @_;
  122.  
  123.   delete $self->{timed_out};
  124.  
  125.   if (!$self->{secs}) { # no timeout!  just call the sub and return.
  126.     return &$sub;
  127.   }
  128.  
  129.   # assertion
  130.   if ($self->{secs} < 0) {
  131.     die "Mail::SpamAssassin::Timeout: oops? neg value for 'secs': $self->{secs}";
  132.   }
  133.  
  134.   my $oldalarm = 0;
  135.   my $ret;
  136.  
  137.   # bug 4699: under heavy load, an alarm may fire while $@ will contain "",
  138.   # which isn't very useful.  this counter works around it safely, since
  139.   # it will not require malloc() be called if it fires
  140.   my $timedout = 0;
  141.  
  142.   eval {
  143.     # note use of local to ensure closed scope here
  144.     local $SIG{ALRM} = sub { $timedout++; die "__alarm__ignore__\n" };
  145.     local $SIG{__DIE__};   # bug 4631
  146.  
  147.     $oldalarm = alarm($self->{secs});
  148.  
  149.     $ret = &$sub;
  150.  
  151.     # Unset the alarm() before we leave eval{ } scope, as that stack-pop
  152.     # operation can take a second or two under load. Note: previous versions
  153.     # restored $oldalarm here; however, that is NOT what we want to do, since
  154.     # it creates a new race condition, namely that an old alarm could then fire
  155.     # while the stack-pop was underway, thereby appearing to be *this* timeout
  156.     # timing out. In terms of how we might possibly have nested timeouts in
  157.     # SpamAssassin, this is an academic issue with little impact, but it's
  158.     # still worth avoiding anyway.
  159.  
  160.     alarm 0;
  161.   };
  162.  
  163.   my $err = $@;
  164.  
  165.   if (defined $oldalarm) {
  166.     # now, we could have died from a SIGALRM == timed out.  if so,
  167.     # restore the previously-active one, or zero all timeouts if none
  168.     # were previously active.
  169.     alarm $oldalarm;
  170.   }
  171.  
  172.   if ($err) {
  173.     if ($err =~ /__alarm__ignore__/) {
  174.       $self->{timed_out} = 1;
  175.     } else {
  176.       if ($and_catch) {
  177.         return $@;
  178.       } else {
  179.         die $@;             # propagate any "real" errors
  180.       }
  181.     }
  182.   } elsif ($timedout) {
  183.     warn "timeout with empty \$@";  # this is worth complaining about
  184.     $self->{timed_out} = 1;
  185.   }
  186.  
  187.   if ($and_catch) {
  188.     return;                 # undef
  189.   } else {
  190.     return $ret;
  191.   }
  192. }
  193.  
  194. ###########################################################################
  195.  
  196. =item $t->timed_out()
  197.  
  198. Returns C<1> if the most recent code executed in C<run()> timed out, or
  199. C<undef> if it did not.
  200.  
  201. =cut
  202.  
  203. sub timed_out {
  204.   my ($self) = @_;
  205.   return $self->{timed_out};
  206. }
  207.  
  208. ###########################################################################
  209.  
  210. =item $t->reset()
  211.  
  212. If called within a C<run()> code reference, causes the current alarm timer to
  213. be reset to its starting value.
  214.  
  215. =cut
  216.  
  217. sub reset {
  218.   my ($self) = @_;
  219.   alarm($self->{secs});
  220. }
  221.  
  222. ###########################################################################
  223.  
  224. 1;
  225.