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