Commit | Line | Data |
3fea05b9 |
1 | package IPC::Run::Timer; |
2 | |
3 | =pod |
4 | |
5 | =head1 NAME |
6 | |
7 | IPC::Run::Timer -- Timer channels for IPC::Run. |
8 | |
9 | =head1 SYNOPSIS |
10 | |
11 | use IPC::Run qw( run timer timeout ); |
12 | ## or IPC::Run::Timer ( timer timeout ); |
13 | ## or IPC::Run::Timer ( :all ); |
14 | |
15 | ## A non-fatal timer: |
16 | $t = timer( 5 ); # or... |
17 | $t = IO::Run::Timer->new( 5 ); |
18 | run $t, ...; |
19 | |
20 | ## A timeout (which is a timer that dies on expiry): |
21 | $t = timeout( 5 ); # or... |
22 | $t = IO::Run::Timer->new( 5, exception => "harness timed out" ); |
23 | |
24 | =head1 DESCRIPTION |
25 | |
26 | This class and module allows timers and timeouts to be created for use |
27 | by IPC::Run. A timer simply expires when it's time is up. A timeout |
28 | is a timer that throws an exception when it expires. |
29 | |
30 | Timeouts are usually a bit simpler to use than timers: they throw an |
31 | exception on expiration so you don't need to check them: |
32 | |
33 | ## Give @cmd 10 seconds to get started, then 5 seconds to respond |
34 | my $t = timeout( 10 ); |
35 | $h = start( |
36 | \@cmd, \$in, \$out, |
37 | $t, |
38 | ); |
39 | pump $h until $out =~ /prompt/; |
40 | |
41 | $in = "some stimulus"; |
42 | $out = ''; |
43 | $t->time( 5 ) |
44 | pump $h until $out =~ /expected response/; |
45 | |
46 | You do need to check timers: |
47 | |
48 | ## Give @cmd 10 seconds to get started, then 5 seconds to respond |
49 | my $t = timer( 10 ); |
50 | $h = start( |
51 | \@cmd, \$in, \$out, |
52 | $t, |
53 | ); |
54 | pump $h until $t->is_expired || $out =~ /prompt/; |
55 | |
56 | $in = "some stimulus"; |
57 | $out = ''; |
58 | $t->time( 5 ) |
59 | pump $h until $out =~ /expected response/ || $t->is_expired; |
60 | |
61 | Timers and timeouts that are reset get started by start() and |
62 | pump(). Timers change state only in pump(). Since run() and |
63 | finish() both call pump(), they act like pump() with repect to |
64 | timers. |
65 | |
66 | Timers and timeouts have three states: reset, running, and expired. |
67 | Setting the timeout value resets the timer, as does calling |
68 | the reset() method. The start() method starts (or restarts) a |
69 | timer with the most recently set time value, no matter what state |
70 | it's in. |
71 | |
72 | =head2 Time values |
73 | |
74 | All time values are in seconds. Times may be specified as integer or |
75 | floating point seconds, optionally preceded by puncuation-separated |
76 | days, hours, and minutes.\ |
77 | |
78 | Examples: |
79 | |
80 | 1 1 second |
81 | 1.1 1.1 seconds |
82 | 60 60 seconds |
83 | 1:0 1 minute |
84 | 1:1 1 minute, 1 second |
85 | 1:90 2 minutes, 30 seconds |
86 | 1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds |
87 | |
88 | Absolute date/time strings are *not* accepted: year, month and |
89 | day-of-month parsing is not available (patches welcome :-). |
90 | |
91 | =head2 Interval fudging |
92 | |
93 | When calculating an end time from a start time and an interval, IPC::Run::Timer |
94 | instances add a little fudge factor. This is to ensure that no time will |
95 | expire before the interval is up. |
96 | |
97 | First a little background. Time is sampled in discrete increments. We'll |
98 | call the |
99 | exact moment that the reported time increments from one interval to the |
100 | next a tick, and the interval between ticks as the time period. Here's |
101 | a diagram of three ticks and the periods between them: |
102 | |
103 | |
104 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... |
105 | ^ ^ ^ |
106 | |<--- period 0 ---->|<--- period 1 ---->| |
107 | | | | |
108 | tick 0 tick 1 tick 2 |
109 | |
110 | To see why the fudge factor is necessary, consider what would happen |
111 | when a timer with an interval of 1 second is started right at the end of |
112 | period 0: |
113 | |
114 | |
115 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... |
116 | ^ ^ ^ ^ |
117 | | | | | |
118 | | | | | |
119 | tick 0 |tick 1 tick 2 |
120 | | |
121 | start $t |
122 | |
123 | Assuming that check() is called many times per period, then the timer |
124 | is likely to expire just after tick 1, since the time reported will have |
125 | lept from the value '0' to the value '1': |
126 | |
127 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... |
128 | ^ ^ ^ ^ ^ |
129 | | | | | | |
130 | | | | | | |
131 | tick 0 |tick 1| tick 2 |
132 | | | |
133 | start $t | |
134 | | |
135 | check $t |
136 | |
137 | Adding a fudge of '1' in this example means that the timer is guaranteed |
138 | not to expire before tick 2. |
139 | |
140 | The fudge is not added to an interval of '0'. |
141 | |
142 | This means that intervals guarantee a minimum interval. Given that |
143 | the process running perl may be suspended for some period of time, or that |
144 | it gets busy doing something time-consuming, there are no other guarantees on |
145 | how long it will take a timer to expire. |
146 | |
147 | =head1 SUBCLASSING |
148 | |
149 | INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping |
150 | pseudohashes out of Perl, this class I<no longer> uses the fields |
151 | pragma. |
152 | |
153 | =head1 FUNCTIONS & METHODS |
154 | |
155 | =over |
156 | |
157 | =cut |
158 | |
159 | use strict; |
160 | use Carp; |
161 | use Fcntl; |
162 | use Symbol; |
163 | use Exporter; |
164 | use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); |
165 | BEGIN { |
166 | $VERSION = '0.84'; |
167 | @ISA = qw( Exporter ); |
168 | @EXPORT_OK = qw( |
169 | check |
170 | end_time |
171 | exception |
172 | expire |
173 | interval |
174 | is_expired |
175 | is_reset |
176 | is_running |
177 | name |
178 | reset |
179 | start |
180 | timeout |
181 | timer |
182 | ); |
183 | |
184 | %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); |
185 | } |
186 | |
187 | require IPC::Run; |
188 | use IPC::Run::Debug; |
189 | |
190 | ## |
191 | ## Some helpers |
192 | ## |
193 | my $resolution = 1; |
194 | |
195 | sub _parse_time { |
196 | for ( $_[0] ) { |
197 | return $_ unless defined $_; |
198 | return $_ if /^\d*(?:\.\d*)?$/; |
199 | |
200 | my @f = reverse split( /[^\d\.]+/i ); |
201 | croak "IPC::Run: invalid time string '$_'" unless @f <= 4; |
202 | my ( $s, $m, $h, $d ) = @f; |
203 | return |
204 | ( ( |
205 | ( $d || 0 ) * 24 |
206 | + ( $h || 0 ) ) * 60 |
207 | + ( $m || 0 ) ) * 60 |
208 | + ( $s || 0 ); |
209 | } |
210 | } |
211 | |
212 | sub _calc_end_time { |
213 | my IPC::Run::Timer $self = shift; |
214 | my $interval = $self->interval; |
215 | $interval += $resolution if $interval; |
216 | $self->end_time( $self->start_time + $interval ); |
217 | } |
218 | |
219 | |
220 | =item timer |
221 | |
222 | A constructor function (not method) of IPC::Run::Timer instances: |
223 | |
224 | $t = timer( 5 ); |
225 | $t = timer( 5, name => 'stall timer', debug => 1 ); |
226 | |
227 | $t = timer; |
228 | $t->interval( 5 ); |
229 | |
230 | run ..., $t; |
231 | run ..., $t = timer( 5 ); |
232 | |
233 | This convenience function is a shortened spelling of |
234 | |
235 | IPC::Run::Timer->new( ... ); |
236 | |
237 | . It returns a timer in the reset state with a given interval. |
238 | |
239 | If an exception is provided, it will be thrown when the timer notices that |
240 | it has expired (in check()). The name is for debugging usage, if you plan on |
241 | having multiple timers around. If no name is provided, a name like "timer #1" |
242 | will be provided. |
243 | |
244 | =cut |
245 | |
246 | sub timer { |
247 | return IPC::Run::Timer->new( @_ ); |
248 | } |
249 | |
250 | |
251 | =item timeout |
252 | |
253 | A constructor function (not method) of IPC::Run::Timer instances: |
254 | |
255 | $t = timeout( 5 ); |
256 | $t = timeout( 5, exception => "kablooey" ); |
257 | $t = timeout( 5, name => "stall", exception => "kablooey" ); |
258 | |
259 | $t = timeout; |
260 | $t->interval( 5 ); |
261 | |
262 | run ..., $t; |
263 | run ..., $t = timeout( 5 ); |
264 | |
265 | A This convenience function is a shortened spelling of |
266 | |
267 | IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ); |
268 | |
269 | . It returns a timer in the reset state that will throw an |
270 | exception when it expires. |
271 | |
272 | Takes the same parameters as L</timer>, any exception passed in overrides |
273 | the default exception. |
274 | |
275 | =cut |
276 | |
277 | sub timeout { |
278 | my $t = IPC::Run::Timer->new( @_ ); |
279 | $t->exception( "IPC::Run: timeout on " . $t->name ) |
280 | unless defined $t->exception; |
281 | return $t; |
282 | } |
283 | |
284 | |
285 | =item new |
286 | |
287 | IPC::Run::Timer->new() ; |
288 | IPC::Run::Timer->new( 5 ) ; |
289 | IPC::Run::Timer->new( 5, exception => 'kablooey' ) ; |
290 | |
291 | Constructor. See L</timer> for details. |
292 | |
293 | =cut |
294 | |
295 | my $timer_counter; |
296 | |
297 | |
298 | sub new { |
299 | my $class = shift; |
300 | $class = ref $class || $class; |
301 | |
302 | my IPC::Run::Timer $self = bless {}, $class; |
303 | |
304 | $self->{STATE} = 0; |
305 | $self->{DEBUG} = 0; |
306 | $self->{NAME} = "timer #" . ++$timer_counter; |
307 | |
308 | while ( @_ ) { |
309 | my $arg = shift; |
310 | if ( $arg =~ /^(?:\d+[^\a\d]){0,3}\d*(?:\.\d*)?$/ ) { |
311 | $self->interval( $arg ); |
312 | } |
313 | elsif ( $arg eq 'exception' ) { |
314 | $self->exception( shift ); |
315 | } |
316 | elsif ( $arg eq 'name' ) { |
317 | $self->name( shift ); |
318 | } |
319 | elsif ( $arg eq 'debug' ) { |
320 | $self->debug( shift ); |
321 | } |
322 | else { |
323 | croak "IPC::Run: unexpected parameter '$arg'"; |
324 | } |
325 | } |
326 | |
327 | _debug $self->name . ' constructed' |
328 | if $self->{DEBUG} || _debugging_details; |
329 | |
330 | return $self; |
331 | } |
332 | |
333 | =item check |
334 | |
335 | check $t; |
336 | check $t, $now; |
337 | $t->check; |
338 | |
339 | Checks to see if a timer has expired since the last check. Has no effect |
340 | on non-running timers. This will throw an exception if one is defined. |
341 | |
342 | IPC::Run::pump() calls this routine for any timers in the harness. |
343 | |
344 | You may pass in a version of now, which is useful in case you have |
345 | it lying around or you want to check several timers with a consistent |
346 | concept of the current time. |
347 | |
348 | Returns the time left before end_time or 0 if end_time is no longer |
349 | in the future or the timer is not running |
350 | (unless, of course, check() expire()s the timer and this |
351 | results in an exception being thrown). |
352 | |
353 | Returns undef if the timer is not running on entry, 0 if check() expires it, |
354 | and the time left if it's left running. |
355 | |
356 | =cut |
357 | |
358 | sub check { |
359 | my IPC::Run::Timer $self = shift; |
360 | return undef if ! $self->is_running; |
361 | return 0 if $self->is_expired; |
362 | |
363 | my ( $now ) = @_; |
364 | $now = _parse_time( $now ); |
365 | $now = time unless defined $now; |
366 | |
367 | _debug( |
368 | "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now |
369 | ) if $self->{DEBUG} || _debugging_details; |
370 | |
371 | my $left = $self->end_time - $now; |
372 | return $left if $left > 0; |
373 | |
374 | $self->expire; |
375 | return 0; |
376 | } |
377 | |
378 | |
379 | =item debug |
380 | |
381 | Sets/gets the current setting of the debugging flag for this timer. This |
382 | has no effect if debugging is not enabled for the current harness. |
383 | |
384 | =cut |
385 | |
386 | |
387 | sub debug { |
388 | my IPC::Run::Timer $self = shift; |
389 | $self->{DEBUG} = shift if @_; |
390 | return $self->{DEBUG}; |
391 | } |
392 | |
393 | |
394 | =item end_time |
395 | |
396 | $et = $t->end_time; |
397 | $et = end_time $t; |
398 | |
399 | $t->end_time( time + 10 ); |
400 | |
401 | Returns the time when this timer will or did expire. Even if this time is |
402 | in the past, the timer may not be expired, since check() may not have been |
403 | called yet. |
404 | |
405 | Note that this end_time is not start_time($t) + interval($t), since some |
406 | small extra amount of time is added to make sure that the timer does not |
407 | expire before interval() elapses. If this were not so, then |
408 | |
409 | Changing end_time() while a timer is running will set the expiration time. |
410 | Changing it while it is expired has no affect, since reset()ing a timer always |
411 | clears the end_time(). |
412 | |
413 | =cut |
414 | |
415 | |
416 | sub end_time { |
417 | my IPC::Run::Timer $self = shift; |
418 | if ( @_ ) { |
419 | $self->{END_TIME} = shift; |
420 | _debug $self->name, ' end_time set to ', $self->{END_TIME} |
421 | if $self->{DEBUG} > 2 || _debugging_details; |
422 | } |
423 | return $self->{END_TIME}; |
424 | } |
425 | |
426 | |
427 | =item exception |
428 | |
429 | $x = $t->exception; |
430 | $t->exception( $x ); |
431 | $t->exception( undef ); |
432 | |
433 | Sets/gets the exception to throw, if any. 'undef' means that no |
434 | exception will be thrown. Exception does not need to be a scalar: you |
435 | may ask that references be thrown. |
436 | |
437 | =cut |
438 | |
439 | |
440 | sub exception { |
441 | my IPC::Run::Timer $self = shift; |
442 | if ( @_ ) { |
443 | $self->{EXCEPTION} = shift; |
444 | _debug $self->name, ' exception set to ', $self->{EXCEPTION} |
445 | if $self->{DEBUG} || _debugging_details; |
446 | } |
447 | return $self->{EXCEPTION}; |
448 | } |
449 | |
450 | |
451 | =item interval |
452 | |
453 | $i = interval $t; |
454 | $i = $t->interval; |
455 | $t->interval( $i ); |
456 | |
457 | Sets the interval. Sets the end time based on the start_time() and the |
458 | interval (and a little fudge) if the timer is running. |
459 | |
460 | =cut |
461 | |
462 | sub interval { |
463 | my IPC::Run::Timer $self = shift; |
464 | if ( @_ ) { |
465 | $self->{INTERVAL} = _parse_time( shift ); |
466 | _debug $self->name, ' interval set to ', $self->{INTERVAL} |
467 | if $self->{DEBUG} > 2 || _debugging_details; |
468 | |
469 | $self->_calc_end_time if $self->state; |
470 | } |
471 | return $self->{INTERVAL}; |
472 | } |
473 | |
474 | |
475 | =item expire |
476 | |
477 | expire $t; |
478 | $t->expire; |
479 | |
480 | Sets the state to expired (undef). |
481 | Will throw an exception if one |
482 | is defined and the timer was not already expired. You can expire a |
483 | reset timer without starting it. |
484 | |
485 | =cut |
486 | |
487 | |
488 | sub expire { |
489 | my IPC::Run::Timer $self = shift; |
490 | if ( defined $self->state ) { |
491 | _debug $self->name . ' expired' |
492 | if $self->{DEBUG} || _debugging; |
493 | |
494 | $self->state( undef ); |
495 | croak $self->exception if $self->exception; |
496 | } |
497 | return undef; |
498 | } |
499 | |
500 | |
501 | =item is_running |
502 | |
503 | =cut |
504 | |
505 | |
506 | sub is_running { |
507 | my IPC::Run::Timer $self = shift; |
508 | return $self->state ? 1 : 0; |
509 | } |
510 | |
511 | |
512 | =item is_reset |
513 | |
514 | =cut |
515 | |
516 | sub is_reset { |
517 | my IPC::Run::Timer $self = shift; |
518 | return defined $self->state && $self->state == 0; |
519 | } |
520 | |
521 | |
522 | =item is_expired |
523 | |
524 | =cut |
525 | |
526 | sub is_expired { |
527 | my IPC::Run::Timer $self = shift; |
528 | return ! defined $self->state; |
529 | } |
530 | |
531 | =item name |
532 | |
533 | Sets/gets this timer's name. The name is only used for debugging |
534 | purposes so you can tell which freakin' timer is doing what. |
535 | |
536 | =cut |
537 | |
538 | sub name { |
539 | my IPC::Run::Timer $self = shift; |
540 | |
541 | $self->{NAME} = shift if @_; |
542 | return defined $self->{NAME} |
543 | ? $self->{NAME} |
544 | : defined $self->{EXCEPTION} |
545 | ? 'timeout' |
546 | : 'timer'; |
547 | } |
548 | |
549 | |
550 | =item reset |
551 | |
552 | reset $t; |
553 | $t->reset; |
554 | |
555 | Resets the timer to the non-running, non-expired state and clears |
556 | the end_time(). |
557 | |
558 | =cut |
559 | |
560 | sub reset { |
561 | my IPC::Run::Timer $self = shift; |
562 | $self->state( 0 ); |
563 | $self->end_time( undef ); |
564 | _debug $self->name . ' reset' |
565 | if $self->{DEBUG} || _debugging; |
566 | |
567 | return undef; |
568 | } |
569 | |
570 | |
571 | =item start |
572 | |
573 | start $t; |
574 | $t->start; |
575 | start $t, $interval; |
576 | start $t, $interval, $now; |
577 | |
578 | Starts or restarts a timer. This always sets the start_time. It sets the |
579 | end_time based on the interval if the timer is running or if no end time |
580 | has been set. |
581 | |
582 | You may pass an optional interval or current time value. |
583 | |
584 | Not passing a defined interval causes the previous interval setting to be |
585 | re-used unless the timer is reset and an end_time has been set |
586 | (an exception is thrown if no interval has been set). |
587 | |
588 | Not passing a defined current time value causes the current time to be used. |
589 | |
590 | Passing a current time value is useful if you happen to have a time value |
591 | lying around or if you want to make sure that several timers are started |
592 | with the same concept of start time. You might even need to lie to an |
593 | IPC::Run::Timer, occasionally. |
594 | |
595 | =cut |
596 | |
597 | sub start { |
598 | my IPC::Run::Timer $self = shift; |
599 | |
600 | my ( $interval, $now ) = map { _parse_time( $_ ) } @_; |
601 | $now = _parse_time( $now ); |
602 | $now = time unless defined $now; |
603 | |
604 | $self->interval( $interval ) if defined $interval; |
605 | |
606 | ## start()ing a running or expired timer clears the end_time, so that the |
607 | ## interval is used. So does specifying an interval. |
608 | $self->end_time( undef ) if ! $self->is_reset || $interval; |
609 | |
610 | croak "IPC::Run: no timer interval or end_time defined for " . $self->name |
611 | unless defined $self->interval || defined $self->end_time; |
612 | |
613 | $self->state( 1 ); |
614 | $self->start_time( $now ); |
615 | ## The "+ 1" is in case the START_TIME was sampled at the end of a |
616 | ## tick (which are one second long in this module). |
617 | $self->_calc_end_time |
618 | unless defined $self->end_time; |
619 | |
620 | _debug( |
621 | $self->name, " started at ", $self->start_time, |
622 | ", with interval ", $self->interval, ", end_time ", $self->end_time |
623 | ) if $self->{DEBUG} || _debugging; |
624 | return undef; |
625 | } |
626 | |
627 | |
628 | =item start_time |
629 | |
630 | Sets/gets the start time, in seconds since the epoch. Setting this manually |
631 | is a bad idea, it's better to call L</start>() at the correct time. |
632 | |
633 | =cut |
634 | |
635 | |
636 | sub start_time { |
637 | my IPC::Run::Timer $self = shift; |
638 | if ( @_ ) { |
639 | $self->{START_TIME} = _parse_time( shift ); |
640 | _debug $self->name, ' start_time set to ', $self->{START_TIME} |
641 | if $self->{DEBUG} > 2 || _debugging; |
642 | } |
643 | |
644 | return $self->{START_TIME}; |
645 | } |
646 | |
647 | |
648 | =item state |
649 | |
650 | $s = state $t; |
651 | $t->state( $s ); |
652 | |
653 | Get/Set the current state. Only use this if you really need to transfer the |
654 | state to/from some variable. |
655 | Use L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>, |
656 | L</is_reset>. |
657 | |
658 | Note: Setting the state to 'undef' to expire a timer will not throw an |
659 | exception. |
660 | |
661 | =cut |
662 | |
663 | sub state { |
664 | my IPC::Run::Timer $self = shift; |
665 | if ( @_ ) { |
666 | $self->{STATE} = shift; |
667 | _debug $self->name, ' state set to ', $self->{STATE} |
668 | if $self->{DEBUG} > 2 || _debugging; |
669 | } |
670 | return $self->{STATE}; |
671 | } |
672 | |
673 | |
674 | 1; |
675 | |
676 | =pod |
677 | |
678 | =back |
679 | |
680 | =head1 TODO |
681 | |
682 | use Time::HiRes; if it's present. |
683 | |
684 | Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals. |
685 | |
686 | =head1 AUTHOR |
687 | |
688 | Barrie Slaymaker <barries@slaysys.com> |
689 | |
690 | =cut |