0: #
1: # Second of a three part post of modules that implement
2: # an extension of Perl's built-in alarm functionality.
3: #
4: # See [Alarm::_TieSIG] and [Alarm::Concurrent]
5: # for the other two parts.
6: #
7: # Updated!  Fixed one or two minor issues and
8: # fixed the documentation a bit.
9: #
10: package Alarm::Queued;
11: 
12: use strict;
13: 
14: =head1 NAME
15: 
16: Alarm::Queued - Allow multiple, queued alarms.
17: 
18: =head1 DESCRIPTION
19: 
20: This module is an attempt to enhance Perl's built-in
21: alarm/C<$SIG{ALRM}> functionality.
22: 
23: The built-in function, and its associated signal handler,
24: allow you to arrange for your program to receive a SIGALRM
25: signal, which you can then catch and deal with appropriately.
26: 
27: Unfortunately, due to the nature of the design of these
28: signals (at the OS level), you can only have one alarm
29: and handler active at any given time.  That's where this
30: module comes in.
31: 
32: This module allows you to define multiple alarms, each
33: with an associated handler.  These alarms are queued, which
34: means that if you set one alarm and then set another alarm,
35: shorter than the first, the second alarm does not go off
36: until after the first one has gone off and been handled.
37: (If you'd like to have the alarms go off as their set time
38: expires, regardless of whether or not previous alarms are
39: still pending, see Alarm::Concurrent.)
40: 
41: To set an alarm, call the C<setalarm()> function with the
42: set time of the alarm and a reference to the subroutine
43: to be called when the alarm goes off.  You can then go on
44: with your program and the alarm will be called after the
45: set time has passed.
46: 
47: It is also possible to set an alarm that does not have a
48: handler associated with it using C<Alarm::Queued::alarm()>.
49: (This function can also be imported into your namespace,
50: in which case it will replace Perl's built-in alarm for
51: your package only.)
52: 
53: If an alarm that does not have a handler associated
54: with it goes off, the default handler, pointed to by
55: C<$Alarm::Queued::DEFAULT_HANLDER>, is called.  You can
56: change the default handler by assigning to this variable.
57: 
58: The default C<$Alarm::Queued::DEFAULT_HANDLER> simply
59: dies with the message "Alarm clock!\n".
60: 
61: =head1 IMPORT/EXPORT
62: 
63: No methods are exported by default but you can import
64: any of the functions in the L<FUNCTIONS|"FUNCTIONS"> section.
65: 
66: You can also import the special tag C<:ALL> which will
67: import all the functions in the L<FUNCTIONS|"FUNCTIONS"> section.
68: 
69: =head1 OVERRIDE
70: 
71: If you import the special tag C<:OVERRIDE>, this module
72: will override Perl's built-in alarm function for
73: B<every namespace> and it will take over Perl's magic
74: C<%SIG> variable, changing any attempts to read or write
75: C<$SIG{ALRM}> into calls to C<gethandler()> and
76: C<sethandler()>, respectively.
77: 
78: This can be useful when you are calling code that tries
79: to set its own alarm the "old fashioned way."  It can also,
80: however, be dangerous.  Overriding alarm is documented and
81: should be stable but taking over C<%SIG> is more risky (see
82: L<CAVEATS|"CAVEATS">).
83: 
84: Note that if you do I<not> override alarm and C<%SIG>, any
85: code you use that sets "legacy alarms" will disable all of
86: your queued alarms.  You can call C<Alarm::Queued::restore()>
87: to reinstall the Alarm::Queued handler.  This function may
88: not be imported.
89: 
90: =cut
91: 
92: use Alarm::_TieSIG; # In case they want to take over $SIG{ALRM}.
93: use Carp;
94: 
95: use Exporter;
96: use vars qw( @ISA @EXPORT_OK %EXPORT_TAGS );
97: @ISA = qw(Exporter);
98: @EXPORT_OK = qw(
99:   setalarm
100:   clearalarm
101:   alarm
102:   sethandler
103:   gethandler
104: );
105: %EXPORT_TAGS = (
106:   ALL => [@EXPORT_OK],
107: );
108: 
109: #
110: # Exporter doesn't allow hooks for handling
111: # special tags.  So, we have to do it ourselves.
112: #
113: sub import {
114:   my $thispkg = shift;
115: 
116:   # Look for and remove special :OVERRIDE tag.
117:   my $override = 0;
118:   @_ = grep { ($_ eq ':OVERLOAD') ? ($override = 1, 0) : 1 } @_;
119: 
120:   if($override) {
121:     $thispkg->export('CORE::GLOBAL', 'alarm');
122:     Alarm::_TieSIG::tiesig(); # ALL YOUR %SIG ARE BELONG TO US!!!
123:   };
124: 
125:   $thispkg->export_to_level(1, $thispkg, @_); # export the rest
126: }
127: 
128: # Called for an alarm with no defined handler.
129: sub _default_handler {
130:   die "Alarm clock!\n";
131: }
132: 
133: use vars '$DEFAULT_HANDLER';
134: $DEFAULT_HANDLER = \&_default_handler; # Overeridable.
135: 
136: #
137: # Each element of @ALARM_QUEUE should be a pointer
138: # to an array containing exactly three elements:
139: #
140: #  0) The duration of the alarm in seconds
141: #  1) The time at which the alarm was set
142: #  2) A pointer to a subroutine that should be called
143: #     when the alarm goes off.
144: #
145: use vars qw( @ALARM_QUEUE );
146: @ALARM_QUEUE = ();
147: 
148: restore(1);  # Install our alarm handler.
149: 
150: # Custom alarm handler.
151: sub _alrm {
152:   return unless(@ALARM_QUEUE);
153: 
154:   # Call handler for this alarm and remove it from the queue.
155:   my $handler = shift(@ALARM_QUEUE)->[2] || $DEFAULT_HANDLER;
156:   $handler->();
157: 
158:   while(@ALARM_QUEUE) {
159:     my $time_remaining = $ALARM_QUEUE[0][1]+$ALARM_QUEUE[0][0]-time;
160:     if($time_remaining <= 0) {
161:       $handler = shift(@ALARM_QUEUE)->[2] || $DEFAULT_HANDLER;
162:       $handler->(); # Call handler for this alarm.
163:     } else {
164:       CORE::alarm($time_remaining);
165:       last;
166:     }
167:   }
168: }
169: 
170: 
171: #********************************************************************#
172: 
173: =head1 FUNCTIONS
174: 
175: The following functions are available for use.
176: 
177: =over 4
178: 
179: =item setalarm SECONDS CODEREF
180: 
181: Sets a new alarm and associates a handler with it.
182: This handler is called when the specified number of
183: seconds have elapsed I<and> all previous alarms
184: have gone off.  See L<DESCRIPTION|"DESCRIPTION"> for
185: more information.
186: 
187: =cut
188: sub setalarm($$) {
189:   my ($alarm, $code) = @_;
190: 
191:   unless(not defined($code) or UNIVERSAL::isa($code, 'CODE')) {
192:     croak("Alarm handler must be CODEREF");
193:   }
194: 
195:   push( @ALARM_QUEUE, [ $alarm, time(), $code ] );
196:   CORE::alarm($alarm) if(@ALARM_QUEUE == 1);
197: }
198: 
199: =item clearalarm INDEX LENGTH
200: 
201: =item clearalarm INDEX
202: 
203: =item clearalarm
204: 
205: Clears one or more previously set alarms.  The index is
206: an array index, with 0 being the currently active alarm
207: and -1 being the last (most recent) alarm that was set.
208: 
209: INDEX defaults to 0 and LENGTH defaults to 1.
210: 
211: If you clear the active alarm and it was blocking other
212: alarms from going off, those alarms are immediately triggered.
213: 
214: =cut
215: sub clearalarm(;$$) {
216:   my $index  = shift || 0;
217:   my $length = shift || 1;
218: 
219:   splice @ALARM_QUEUE, $index, $length;
220: 
221:   unless($index) {
222:     while(@ALARM_QUEUE) {
223:       my $time_remaining = $ALARM_QUEUE[0][1]+$ALARM_QUEUE[0][0]-time;
224:       if($time_remaining <= 0) {
225:         my $handler = shift(@ALARM_QUEUE)->[2] || \&default_handler;
226:         $handler->(); # Call handler for this alarm.
227:       } else {
228:         CORE::alarm($time_remaining);
229:         last;
230:       }
231:     }
232:   }
233: }
234: 
235: =item alarm SECONDS
236: 
237: =item alarm
238: 
239: Creates a new alarm with no handler.  A handler can
240: later be set for it via sethandler() or C<$SIG{ALRM}>,
241: if overridden.
242: 
243: For the most part, this function behaves exactly like
244: Perl's built-in alarm function, except that it sets up a
245: concurrent alarm instead.  Thus, each call to alarm does
246: not disable previous alarms unless called with a set time
247: of 0.
248: 
249: Calling C<alarm()> with a set time of 0 will disable the
250: last alarm set.
251: 
252: If SECONDS is not specified, the value stored in C<$_>
253: is used.
254: 
255: =cut
256: sub alarm(;$) {
257:   my $alarm = @_ ? shift : $_;
258: 
259:   if($alarm == 0) {
260:     clearalarm(-1);
261:   } else {
262:     push( @ALARM_QUEUE, [ $alarm, time(), undef ] );
263:     CORE::alarm($alarm) if(@ALARM_QUEUE == 1);
264:   }
265: }
266: 
267: =item sethandler INDEX CODEREF
268: 
269: =item sethandler CODEREF
270: 
271: Sets a handler for the alarm found at INDEX in the queue.  This
272: is an array index, so negative values may be used to indicate
273: a position relative to the end of the queue.
274: 
275: If INDEX is not specified, the handler is set for the last
276: alarm in the queue that doesn't have one associated with it.
277: This means that if you set multiple alarms using C<alarm()>,
278: you should arrange their respective C<sethandler()>'s in the
279: I<opposite> order.
280: 
281: =cut
282: sub sethandler($;$) {
283: 
284:   unless(not defined($_[-1]) or UNIVERSAL::isa($_[-1], 'CODE')) {
285:     croak("Alarm handler must be CODEREF");
286:   }
287: 
288:   if(@_ == 2) {
289:     $ALARM_QUEUE[$_[0]]->[2] = $_[1];
290:   } else {
291:     foreach my $alarm (reverse @ALARM_QUEUE) {
292:       if(not defined $alarm->[2]) {
293:         $alarm->[2] = shift();
294:         last;
295:       }
296:     }
297:   }
298: }
299: 
300: =item gethandler INDEX
301: 
302: =item gethandler
303: 
304: Returns the handler for the alarm found at INDEX in the queue.
305: This is an array index, so negative values may be used.
306: 
307: If INDEX is not specified, returns the handler for the currently
308: active alarm.
309: 
310: =cut
311: sub gethandler(;$) {
312:   my $index = shift || 0;
313:   return(
314:     ($index < @ALARM_QUEUE and $index > -1)
315:       ?
316:     $ALARM_QUEUE[$index][2]
317:       :
318:     undef
319:   );
320: }
321: 
322: =item restore FLAG
323: 
324: =item restore
325: 
326: This function reinstalls the Alarm::Queued alarm handler
327: if it has been replaced by a "legacy alarm handler."
328: 
329: If FLAG is present and true, C<restore()> will save the
330: current handler by setting it as a new queued alarm (as
331: if you had called C<setalarm()> for it).
332: 
333: This function may not be imported.
334: 
335: Note:  Do B<not> call this function if you have imported
336: the C<:OVERLOAD> symbol.  It can have unpredictable results.
337: 
338: =cut
339: sub restore(;$) {
340:   return if(defined($SIG{ALRM}) and $SIG{ALRM} == \&_alrm);
341: 
342:   my $oldalrm = CORE::alarm(5);
343: 
344:   if($oldalrm and shift) {
345:     # Save legacy alarm.
346:     setalarm($oldalrm, $SIG{ALRM});
347:   }
348: 
349:   # Install our alarm handler.
350:   $SIG{ALRM} = \&_alrm;
351: }
352: 
353: =head1 CAVEATS
354: 
355: =over 4
356: 
357: =item *
358: 
359: C<%SIG> is Perl magic and should probably not be messed
360: with, though I have not witnessed any problems in the
361: (admittedly limited) testing I've done.  I would be
362: interested to hear from anyone who performs extensive
363: testing, with different versions of Perl, of the
364: reliability of doing this.
365: 
366: Moreover, since there is no way to just take over
367: C<$SIG{ALRM}>, the entire magic hash is usurped and any
368: other C<%SIG}> accesses are simply passed through to the
369: original magic hash.  This means that if there I<are> any
370: problems, they will most likely affect all other signal
371: handlers you have defined, including C<$SIG{__WARN__}>
372: and C<$SIG{__DIE__}> and others.
373: 
374: In other words, if you're going to use the :OVERRIDE
375: option, you do so at your own risk (and you'd better be
376: pretty damn sure of yourself, too).
377: 
378: =item *
379: 
380: The default C<$DEFAULT_HANDLER> simply dies with the
381: message "Alarm clock!\n".
382: 
383: =item *
384: 
385: All warnings about alarms possibly being off by up to a full
386: second still apply.  See the documentation for alarm for more
387: information.
388: 
389: =item *
390: 
391: The alarm handling routine does not make any allowances
392: for systems that clear the alarm handler before it is
393: called.  This may be changed in the future.
394: 
395: =item *
396: 
397: According to L<perlipc/"Signals">, doing just about I<anything>
398: in signal handling routines is dangerous because it might
399: be called during a non-re-entrant system library routines
400: which could cause a memory fault and core dump.
401: 
402: The Alarm::Queued alarm handling routine does quite a bit.
403: 
404: You have been warned.
405: 
406: =back
407: 
408: =head1 AUTHOR
409: 
410: Written by Cory Johns (c) 2001.
411: 
412: =cut
413: 
414: 1;