1: =head1 NAME
   2: 
   3: TimeLimit - limit execution time
   4: 
   5: =head1 SYNOPSIS
   6: 
   7:   use TimeLimit
   8:   time_limit {
   9:       # Some code which might take a long time
  10:   } or warn "Timeout";
  11: 
  12: =head1 DESCRIPTION
  13: 
  14: Provides time_limit for adding easy to use timeouts to your programs.
  15: 
  16: =head1 FUNCTIONS
  17: 
  18: =cut
  19: 
  20: ############################################################
  21: 
  22: package TimeLimit;
  23: 
  24: use strict;
  25: use Carp;
  26: use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  27: 
  28: require Exporter;
  29: 
  30: @ISA = qw(Exporter);
  31: @EXPORT_OK = ( );
  32: @EXPORT = qw(
  33:     time_limit
  34: );
  35: $VERSION = '1.00';
  36: 
  37: ############################################################
  38: 
  39: =head2 time_limit
  40: 
  41: Time out the subroutine or subroutine block using alarm, being careful
  42: to save and restore the alarm properly.
  43: 
  44: You may nest this function inside other time_limits or alarm calls.
  45: Inside a nested time_limit the outer time_limit is turned off for the
  46: duration of the inner timeout, and restored when the inner time_limit
  47: exits.
  48: 
  49: Input:
  50: 
  51:     { subroutine block }
  52:     timeout - optional defaults to 30 seconds
  53: 
  54: Output:
  55: 
  56:     $ok  - returns 1 for OK or undef for false
  57: 
  58: Use like this
  59: 
  60:     time_limit
  61:     {
  62:         long_function();
  63:         more_stuff();
  64:     } 60
  65:     or die "Stuff timedout after 60 seconds";
  66: 
  67: Or this where the 'or do { }' block acts like an 'else' block.
  68: 
  69:     time_limit
  70:     {
  71:         long_function(1);
  72:         long_function(2);
  73:     } or do
  74:     {
  75:         something_on_timeout();
  76:     };
  77: 
  78: =cut
  79: 
  80: ############################################################
  81: 
  82: my $time_limit_invocation = 0;
  83: 
  84: sub time_limit (&;$)
  85: {
  86:     my ($sub, $timeout) = @_;
  87:     my $die_text = "time_limit: " . $time_limit_invocation++ . "\n";
  88:     $timeout ||= 30;
  89:     my $old_alarm = alarm(0);        # turn alarm off and read old value
  90:     {
  91:         local $SIG{ALRM} = 'IGNORE'; # ignore alarms in this scope
  92: 
  93:         eval
  94:         {
  95:             local $SIG{__DIE__};     # turn die handler off in eval block
  96:             local $SIG{ALRM} = sub { die $die_text };
  97:             alarm($timeout);         # set alarm
  98:             $sub->();                # do the user's code
  99:         };
 100: 
 101:         # Note the alarm is still active here - however we assume that
 102:         # if we got here without an alarm the user's code succeeded -
 103:         # hence the IGNOREing of alarms in this scope
 104: 
 105:         alarm 0;                     # kill off alarm
 106:     }
 107: 
 108:     alarm $old_alarm;                # restore alarm
 109: 
 110:     if ($@)
 111:     {
 112:         # the eval returned an error
 113:         return 0 if $@ eq $die_text; # show we timed out ($@ is set)
 114:         die $@;                      # propagate error
 115:     }
 116: 
 117:     return 1;                        # all ok
 118: }
 119:     
 120: ############################################################
 121: 
 122: =head1 EXPORT
 123: 
 124:     time_limit
 125: 
 126: =head1 AUTHOR
 127: 
 128: Nick Craig-Wood
 129: 
 130: =head1 CHANGES
 131: 
 132: =head2 2001-04-21 ncw
 133: 
 134: Release 1.00
 135: 
 136: Created
 137: 
 138: =head1 SEE ALSO
 139: 
 140: perl(1).
 141: 
 142: =cut
 143: 
 144: ############################################################
 145: 1;
 146: __END__