Initial Commit
This commit is contained in:
Riley Schneider
670
database/perl/vendor/lib/IPC/Run/Timer.pm
vendored
Normal file
670
database/perl/vendor/lib/IPC/Run/Timer.pm
vendored
Normal file
@@ -0,0 +1,670 @@
|
||||
package IPC::Run::Timer;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
IPC::Run::Timer -- Timer channels for IPC::Run.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use IPC::Run qw( run timer timeout );
|
||||
## or IPC::Run::Timer ( timer timeout );
|
||||
## or IPC::Run::Timer ( :all );
|
||||
|
||||
## A non-fatal timer:
|
||||
$t = timer( 5 ); # or...
|
||||
$t = IO::Run::Timer->new( 5 );
|
||||
run $t, ...;
|
||||
|
||||
## A timeout (which is a timer that dies on expiry):
|
||||
$t = timeout( 5 ); # or...
|
||||
$t = IO::Run::Timer->new( 5, exception => "harness timed out" );
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class and module allows timers and timeouts to be created for use
|
||||
by IPC::Run. A timer simply expires when it's time is up. A timeout
|
||||
is a timer that throws an exception when it expires.
|
||||
|
||||
Timeouts are usually a bit simpler to use than timers: they throw an
|
||||
exception on expiration so you don't need to check them:
|
||||
|
||||
## Give @cmd 10 seconds to get started, then 5 seconds to respond
|
||||
my $t = timeout( 10 );
|
||||
$h = start(
|
||||
\@cmd, \$in, \$out,
|
||||
$t,
|
||||
);
|
||||
pump $h until $out =~ /prompt/;
|
||||
|
||||
$in = "some stimulus";
|
||||
$out = '';
|
||||
$t->time( 5 )
|
||||
pump $h until $out =~ /expected response/;
|
||||
|
||||
You do need to check timers:
|
||||
|
||||
## Give @cmd 10 seconds to get started, then 5 seconds to respond
|
||||
my $t = timer( 10 );
|
||||
$h = start(
|
||||
\@cmd, \$in, \$out,
|
||||
$t,
|
||||
);
|
||||
pump $h until $t->is_expired || $out =~ /prompt/;
|
||||
|
||||
$in = "some stimulus";
|
||||
$out = '';
|
||||
$t->time( 5 )
|
||||
pump $h until $out =~ /expected response/ || $t->is_expired;
|
||||
|
||||
Timers and timeouts that are reset get started by start() and
|
||||
pump(). Timers change state only in pump(). Since run() and
|
||||
finish() both call pump(), they act like pump() with respect to
|
||||
timers.
|
||||
|
||||
Timers and timeouts have three states: reset, running, and expired.
|
||||
Setting the timeout value resets the timer, as does calling
|
||||
the reset() method. The start() method starts (or restarts) a
|
||||
timer with the most recently set time value, no matter what state
|
||||
it's in.
|
||||
|
||||
=head2 Time values
|
||||
|
||||
All time values are in seconds. Times may be any kind of perl number,
|
||||
e.g. as integer or floating point seconds, optionally preceded by
|
||||
punctuation-separated days, hours, and minutes.
|
||||
|
||||
Examples:
|
||||
|
||||
1 1 second
|
||||
1.1 1.1 seconds
|
||||
60 60 seconds
|
||||
1:0 1 minute
|
||||
1:1 1 minute, 1 second
|
||||
1:90 2 minutes, 30 seconds
|
||||
1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds
|
||||
'inf' the infinity perl special number (the timer never finishes)
|
||||
|
||||
Absolute date/time strings are *not* accepted: year, month and
|
||||
day-of-month parsing is not available (patches welcome :-).
|
||||
|
||||
=head2 Interval fudging
|
||||
|
||||
When calculating an end time from a start time and an interval, IPC::Run::Timer
|
||||
instances add a little fudge factor. This is to ensure that no time will
|
||||
expire before the interval is up.
|
||||
|
||||
First a little background. Time is sampled in discrete increments. We'll
|
||||
call the
|
||||
exact moment that the reported time increments from one interval to the
|
||||
next a tick, and the interval between ticks as the time period. Here's
|
||||
a diagram of three ticks and the periods between them:
|
||||
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^
|
||||
|<--- period 0 ---->|<--- period 1 ---->|
|
||||
| | |
|
||||
tick 0 tick 1 tick 2
|
||||
|
||||
To see why the fudge factor is necessary, consider what would happen
|
||||
when a timer with an interval of 1 second is started right at the end of
|
||||
period 0:
|
||||
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^ ^
|
||||
| | | |
|
||||
| | | |
|
||||
tick 0 |tick 1 tick 2
|
||||
|
|
||||
start $t
|
||||
|
||||
Assuming that check() is called many times per period, then the timer
|
||||
is likely to expire just after tick 1, since the time reported will have
|
||||
lept from the value '0' to the value '1':
|
||||
|
||||
-0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-...
|
||||
^ ^ ^ ^ ^
|
||||
| | | | |
|
||||
| | | | |
|
||||
tick 0 |tick 1| tick 2
|
||||
| |
|
||||
start $t |
|
||||
|
|
||||
check $t
|
||||
|
||||
Adding a fudge of '1' in this example means that the timer is guaranteed
|
||||
not to expire before tick 2.
|
||||
|
||||
The fudge is not added to an interval of '0'.
|
||||
|
||||
This means that intervals guarantee a minimum interval. Given that
|
||||
the process running perl may be suspended for some period of time, or that
|
||||
it gets busy doing something time-consuming, there are no other guarantees on
|
||||
how long it will take a timer to expire.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping
|
||||
pseudohashes out of Perl, this class I<no longer> uses the fields
|
||||
pragma.
|
||||
|
||||
=head1 FUNCTIONS & METHODS
|
||||
|
||||
=over
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
use Carp;
|
||||
use Fcntl;
|
||||
use Symbol;
|
||||
use Exporter;
|
||||
use Scalar::Util ();
|
||||
use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
|
||||
|
||||
BEGIN {
|
||||
$VERSION = '20200505.0';
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT_OK = qw(
|
||||
check
|
||||
end_time
|
||||
exception
|
||||
expire
|
||||
interval
|
||||
is_expired
|
||||
is_reset
|
||||
is_running
|
||||
name
|
||||
reset
|
||||
start
|
||||
timeout
|
||||
timer
|
||||
);
|
||||
|
||||
%EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
|
||||
}
|
||||
|
||||
require IPC::Run;
|
||||
use IPC::Run::Debug;
|
||||
|
||||
##
|
||||
## Some helpers
|
||||
##
|
||||
my $resolution = 1;
|
||||
|
||||
sub _parse_time {
|
||||
for ( $_[0] ) {
|
||||
my $val;
|
||||
if ( not defined $_ ) {
|
||||
$val = $_;
|
||||
}
|
||||
else {
|
||||
my @f = split( /:/, $_, -1 );
|
||||
if ( scalar @f > 4 ) {
|
||||
croak "IPC::Run: expected <= 4 elements in time string '$_'";
|
||||
}
|
||||
for (@f) {
|
||||
if ( not Scalar::Util::looks_like_number($_) ) {
|
||||
croak "IPC::Run: non-numeric element '$_' in time string '$_'";
|
||||
}
|
||||
}
|
||||
my ( $s, $m, $h, $d ) = reverse @f;
|
||||
$val = ( ( ( $d || 0 ) * 24 + ( $h || 0 ) ) * 60 + ( $m || 0 ) ) * 60 + ( $s || 0 );
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub _calc_end_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
my $interval = $self->interval;
|
||||
$interval += $resolution if $interval;
|
||||
$self->end_time( $self->start_time + $interval );
|
||||
}
|
||||
|
||||
=item timer
|
||||
|
||||
A constructor function (not method) of IPC::Run::Timer instances:
|
||||
|
||||
$t = timer( 5 );
|
||||
$t = timer( 5, name => 'stall timer', debug => 1 );
|
||||
|
||||
$t = timer;
|
||||
$t->interval( 5 );
|
||||
|
||||
run ..., $t;
|
||||
run ..., $t = timer( 5 );
|
||||
|
||||
This convenience function is a shortened spelling of
|
||||
|
||||
IPC::Run::Timer->new( ... );
|
||||
|
||||
. It returns a timer in the reset state with a given interval.
|
||||
|
||||
If an exception is provided, it will be thrown when the timer notices that
|
||||
it has expired (in check()). The name is for debugging usage, if you plan on
|
||||
having multiple timers around. If no name is provided, a name like "timer #1"
|
||||
will be provided.
|
||||
|
||||
=cut
|
||||
|
||||
sub timer {
|
||||
return IPC::Run::Timer->new(@_);
|
||||
}
|
||||
|
||||
=item timeout
|
||||
|
||||
A constructor function (not method) of IPC::Run::Timer instances:
|
||||
|
||||
$t = timeout( 5 );
|
||||
$t = timeout( 5, exception => "kablooey" );
|
||||
$t = timeout( 5, name => "stall", exception => "kablooey" );
|
||||
|
||||
$t = timeout;
|
||||
$t->interval( 5 );
|
||||
|
||||
run ..., $t;
|
||||
run ..., $t = timeout( 5 );
|
||||
|
||||
A This convenience function is a shortened spelling of
|
||||
|
||||
IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... );
|
||||
|
||||
. It returns a timer in the reset state that will throw an
|
||||
exception when it expires.
|
||||
|
||||
Takes the same parameters as L</timer>, any exception passed in overrides
|
||||
the default exception.
|
||||
|
||||
=cut
|
||||
|
||||
sub timeout {
|
||||
my $t = IPC::Run::Timer->new(@_);
|
||||
$t->exception( "IPC::Run: timeout on " . $t->name )
|
||||
unless defined $t->exception;
|
||||
return $t;
|
||||
}
|
||||
|
||||
=item new
|
||||
|
||||
IPC::Run::Timer->new() ;
|
||||
IPC::Run::Timer->new( 5 ) ;
|
||||
IPC::Run::Timer->new( 5, exception => 'kablooey' ) ;
|
||||
|
||||
Constructor. See L</timer> for details.
|
||||
|
||||
=cut
|
||||
|
||||
my $timer_counter;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
|
||||
my IPC::Run::Timer $self = bless {}, $class;
|
||||
|
||||
$self->{STATE} = 0;
|
||||
$self->{DEBUG} = 0;
|
||||
$self->{NAME} = "timer #" . ++$timer_counter;
|
||||
|
||||
while (@_) {
|
||||
my $arg = shift;
|
||||
if ( $arg eq 'exception' ) {
|
||||
$self->exception(shift);
|
||||
}
|
||||
elsif ( $arg eq 'name' ) {
|
||||
$self->name(shift);
|
||||
}
|
||||
elsif ( $arg eq 'debug' ) {
|
||||
$self->debug(shift);
|
||||
}
|
||||
else {
|
||||
$self->interval($arg);
|
||||
}
|
||||
}
|
||||
|
||||
_debug $self->name . ' constructed'
|
||||
if $self->{DEBUG} || _debugging_details;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
=item check
|
||||
|
||||
check $t;
|
||||
check $t, $now;
|
||||
$t->check;
|
||||
|
||||
Checks to see if a timer has expired since the last check. Has no effect
|
||||
on non-running timers. This will throw an exception if one is defined.
|
||||
|
||||
IPC::Run::pump() calls this routine for any timers in the harness.
|
||||
|
||||
You may pass in a version of now, which is useful in case you have
|
||||
it lying around or you want to check several timers with a consistent
|
||||
concept of the current time.
|
||||
|
||||
Returns the time left before end_time or 0 if end_time is no longer
|
||||
in the future or the timer is not running
|
||||
(unless, of course, check() expire()s the timer and this
|
||||
results in an exception being thrown).
|
||||
|
||||
Returns undef if the timer is not running on entry, 0 if check() expires it,
|
||||
and the time left if it's left running.
|
||||
|
||||
=cut
|
||||
|
||||
sub check {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return undef if !$self->is_running;
|
||||
return 0 if $self->is_expired;
|
||||
|
||||
my ($now) = @_;
|
||||
$now = _parse_time($now);
|
||||
$now = time unless defined $now;
|
||||
|
||||
_debug( "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now ) if $self->{DEBUG} || _debugging_details;
|
||||
|
||||
my $left = $self->end_time - $now;
|
||||
return $left if $left > 0;
|
||||
|
||||
$self->expire;
|
||||
return 0;
|
||||
}
|
||||
|
||||
=item debug
|
||||
|
||||
Sets/gets the current setting of the debugging flag for this timer. This
|
||||
has no effect if debugging is not enabled for the current harness.
|
||||
|
||||
=cut
|
||||
|
||||
sub debug {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
$self->{DEBUG} = shift if @_;
|
||||
return $self->{DEBUG};
|
||||
}
|
||||
|
||||
=item end_time
|
||||
|
||||
$et = $t->end_time;
|
||||
$et = end_time $t;
|
||||
|
||||
$t->end_time( time + 10 );
|
||||
|
||||
Returns the time when this timer will or did expire. Even if this time is
|
||||
in the past, the timer may not be expired, since check() may not have been
|
||||
called yet.
|
||||
|
||||
Note that this end_time is not start_time($t) + interval($t), since some
|
||||
small extra amount of time is added to make sure that the timer does not
|
||||
expire before interval() elapses. If this were not so, then
|
||||
|
||||
Changing end_time() while a timer is running will set the expiration time.
|
||||
Changing it while it is expired has no affect, since reset()ing a timer always
|
||||
clears the end_time().
|
||||
|
||||
=cut
|
||||
|
||||
sub end_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{END_TIME} = shift;
|
||||
_debug $self->name, ' end_time set to ', $self->{END_TIME}
|
||||
if $self->{DEBUG} > 2 || _debugging_details;
|
||||
}
|
||||
return $self->{END_TIME};
|
||||
}
|
||||
|
||||
=item exception
|
||||
|
||||
$x = $t->exception;
|
||||
$t->exception( $x );
|
||||
$t->exception( undef );
|
||||
|
||||
Sets/gets the exception to throw, if any. 'undef' means that no
|
||||
exception will be thrown. Exception does not need to be a scalar: you
|
||||
may ask that references be thrown.
|
||||
|
||||
=cut
|
||||
|
||||
sub exception {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{EXCEPTION} = shift;
|
||||
_debug $self->name, ' exception set to ', $self->{EXCEPTION}
|
||||
if $self->{DEBUG} || _debugging_details;
|
||||
}
|
||||
return $self->{EXCEPTION};
|
||||
}
|
||||
|
||||
=item interval
|
||||
|
||||
$i = interval $t;
|
||||
$i = $t->interval;
|
||||
$t->interval( $i );
|
||||
|
||||
Sets the interval. Sets the end time based on the start_time() and the
|
||||
interval (and a little fudge) if the timer is running.
|
||||
|
||||
=cut
|
||||
|
||||
sub interval {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{INTERVAL} = _parse_time(shift);
|
||||
_debug $self->name, ' interval set to ', $self->{INTERVAL}
|
||||
if $self->{DEBUG} > 2 || _debugging_details;
|
||||
|
||||
$self->_calc_end_time if $self->state;
|
||||
}
|
||||
return $self->{INTERVAL};
|
||||
}
|
||||
|
||||
=item expire
|
||||
|
||||
expire $t;
|
||||
$t->expire;
|
||||
|
||||
Sets the state to expired (undef).
|
||||
Will throw an exception if one
|
||||
is defined and the timer was not already expired. You can expire a
|
||||
reset timer without starting it.
|
||||
|
||||
=cut
|
||||
|
||||
sub expire {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if ( defined $self->state ) {
|
||||
_debug $self->name . ' expired'
|
||||
if $self->{DEBUG} || _debugging;
|
||||
|
||||
$self->state(undef);
|
||||
croak $self->exception if $self->exception;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item is_running
|
||||
|
||||
=cut
|
||||
|
||||
sub is_running {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return $self->state ? 1 : 0;
|
||||
}
|
||||
|
||||
=item is_reset
|
||||
|
||||
=cut
|
||||
|
||||
sub is_reset {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return defined $self->state && $self->state == 0;
|
||||
}
|
||||
|
||||
=item is_expired
|
||||
|
||||
=cut
|
||||
|
||||
sub is_expired {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
return !defined $self->state;
|
||||
}
|
||||
|
||||
=item name
|
||||
|
||||
Sets/gets this timer's name. The name is only used for debugging
|
||||
purposes so you can tell which freakin' timer is doing what.
|
||||
|
||||
=cut
|
||||
|
||||
sub name {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
|
||||
$self->{NAME} = shift if @_;
|
||||
return
|
||||
defined $self->{NAME} ? $self->{NAME}
|
||||
: defined $self->{EXCEPTION} ? 'timeout'
|
||||
: 'timer';
|
||||
}
|
||||
|
||||
=item reset
|
||||
|
||||
reset $t;
|
||||
$t->reset;
|
||||
|
||||
Resets the timer to the non-running, non-expired state and clears
|
||||
the end_time().
|
||||
|
||||
=cut
|
||||
|
||||
sub reset {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
$self->state(0);
|
||||
$self->end_time(undef);
|
||||
_debug $self->name . ' reset'
|
||||
if $self->{DEBUG} || _debugging;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item start
|
||||
|
||||
start $t;
|
||||
$t->start;
|
||||
start $t, $interval;
|
||||
start $t, $interval, $now;
|
||||
|
||||
Starts or restarts a timer. This always sets the start_time. It sets the
|
||||
end_time based on the interval if the timer is running or if no end time
|
||||
has been set.
|
||||
|
||||
You may pass an optional interval or current time value.
|
||||
|
||||
Not passing a defined interval causes the previous interval setting to be
|
||||
re-used unless the timer is reset and an end_time has been set
|
||||
(an exception is thrown if no interval has been set).
|
||||
|
||||
Not passing a defined current time value causes the current time to be used.
|
||||
|
||||
Passing a current time value is useful if you happen to have a time value
|
||||
lying around or if you want to make sure that several timers are started
|
||||
with the same concept of start time. You might even need to lie to an
|
||||
IPC::Run::Timer, occasionally.
|
||||
|
||||
=cut
|
||||
|
||||
sub start {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
|
||||
my ( $interval, $now ) = map { _parse_time($_) } @_;
|
||||
$now = _parse_time($now);
|
||||
$now = time unless defined $now;
|
||||
|
||||
$self->interval($interval) if defined $interval;
|
||||
|
||||
## start()ing a running or expired timer clears the end_time, so that the
|
||||
## interval is used. So does specifying an interval.
|
||||
$self->end_time(undef) if !$self->is_reset || $interval;
|
||||
|
||||
croak "IPC::Run: no timer interval or end_time defined for " . $self->name
|
||||
unless defined $self->interval || defined $self->end_time;
|
||||
|
||||
$self->state(1);
|
||||
$self->start_time($now);
|
||||
## The "+ 1" is in case the START_TIME was sampled at the end of a
|
||||
## tick (which are one second long in this module).
|
||||
$self->_calc_end_time
|
||||
unless defined $self->end_time;
|
||||
|
||||
_debug(
|
||||
$self->name, " started at ", $self->start_time,
|
||||
", with interval ", $self->interval, ", end_time ", $self->end_time
|
||||
) if $self->{DEBUG} || _debugging;
|
||||
return undef;
|
||||
}
|
||||
|
||||
=item start_time
|
||||
|
||||
Sets/gets the start time, in seconds since the epoch. Setting this manually
|
||||
is a bad idea, it's better to call L</start>() at the correct time.
|
||||
|
||||
=cut
|
||||
|
||||
sub start_time {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{START_TIME} = _parse_time(shift);
|
||||
_debug $self->name, ' start_time set to ', $self->{START_TIME}
|
||||
if $self->{DEBUG} > 2 || _debugging;
|
||||
}
|
||||
|
||||
return $self->{START_TIME};
|
||||
}
|
||||
|
||||
=item state
|
||||
|
||||
$s = state $t;
|
||||
$t->state( $s );
|
||||
|
||||
Get/Set the current state. Only use this if you really need to transfer the
|
||||
state to/from some variable.
|
||||
Use L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>,
|
||||
L</is_reset>.
|
||||
|
||||
Note: Setting the state to 'undef' to expire a timer will not throw an
|
||||
exception.
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
sub state {
|
||||
my IPC::Run::Timer $self = shift;
|
||||
if (@_) {
|
||||
$self->{STATE} = shift;
|
||||
_debug $self->name, ' state set to ', $self->{STATE}
|
||||
if $self->{DEBUG} > 2 || _debugging;
|
||||
}
|
||||
return $self->{STATE};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=head1 TODO
|
||||
|
||||
use Time::HiRes; if it's present.
|
||||
|
||||
Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Barrie Slaymaker <barries@slaysys.com>
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user