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