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