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