| File: | lib/Time/DoAfter.pm |
| Coverage: | 83.5% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 1 | package Time::DoAfter; | ||||||
| 2 | # ABSTRACT: Wait before doing by label contoller singleton | ||||||
| 3 | |||||||
| 4 | 1 1 1 | 3 3 20 | use strict; | ||||
| 5 | 1 1 1 | 3 1 23 | use warnings; | ||||
| 6 | |||||||
| 7 | 1 1 1 | 3 1 39 | use Carp 'croak'; | ||||
| 8 | 1 1 1 | 3 1 5 | use Time::HiRes qw( time sleep ); | ||||
| 9 | |||||||
| 10 | # VERSION | ||||||
| 11 | |||||||
| 12 | sub _input_handler { | ||||||
| 13 | 6 | 8 | my ( $input, $set ) = ( {}, {} ); | ||||
| 14 | |||||||
| 15 | my $push_input = sub { | ||||||
| 16 | $input->{ $set->{label} || '_label' } = { | ||||||
| 17 | wait => $set->{wait}, | ||||||
| 18 | do => $set->{do}, | ||||||
| 19 | 6 | 30 | }; | ||||
| 20 | 6 | 6 | $set = {}; | ||||
| 21 | 6 | 16 | }; | ||||
| 22 | |||||||
| 23 | 6 | 11 | while (@_) { | ||||
| 24 | 4 | 4 | my $thing = shift; | ||||
| 25 | 4 | 53 | my $type = | ||||
| 26 | ( ref $thing eq 'CODE' ) ? 'do' : | ||||||
| 27 | ( ref $thing eq 'ARRAY' or not ref $thing and defined $thing and $thing =~ m/^[\d\.]+$/ ) ? 'wait' : | ||||||
| 28 | ( not ref $thing and defined $thing and $thing !~ m/^[\d\.]+$/ ) ? 'label' : 'error'; | ||||||
| 29 | |||||||
| 30 | 4 | 8 | croak('Unable to understand input provided; at least one thing provided is not a proper input') | ||||
| 31 | if ( $type eq 'error' ); | ||||||
| 32 | |||||||
| 33 | 4 | 6 | $push_input->() if ( exists $set->{$type} ); | ||||
| 34 | 4 | 10 | $set->{$type} = $thing; | ||||
| 35 | } | ||||||
| 36 | |||||||
| 37 | 6 | 7 | $push_input->(); | ||||
| 38 | 6 | 18 | return $input; | ||||
| 39 | } | ||||||
| 40 | |||||||
| 41 | { | ||||||
| 42 | my $singleton; | ||||||
| 43 | |||||||
| 44 | sub new { | ||||||
| 45 | 4 | 1 | 18 | return $singleton if ($singleton); | |||
| 46 | 1 | 1 | shift; | ||||
| 47 | |||||||
| 48 | 1 | 3 | my $self = bless( _input_handler(@_), __PACKAGE__ ); | ||||
| 49 | 1 | 1 | $singleton = $self; | ||||
| 50 | 1 | 5 | return $self; | ||||
| 51 | } | ||||||
| 52 | } | ||||||
| 53 | |||||||
| 54 | sub do { | ||||||
| 55 | 5 | 1 | 6 | my $self = shift; | |||
| 56 | 5 | 7 | my $input = _input_handler(@_); | ||||
| 57 | |||||||
| 58 | 5 | 13 | for my $label ( keys %$input ) { | ||||
| 59 | 5 | 23 | $input->{$label}{wait} //= $self->{$label}{wait} // 0; | ||||
| 60 | 5 | 24 | $input->{$label}{do} ||= $self->{$label}{do} || sub {}; | ||||
| 61 | |||||||
| 62 | 5 | 9 | if ( $self->{$label}{last} ) { | ||||
| 63 | 3 | 3 | my $wait; | ||||
| 64 | 3 | 5 | if ( ref $self->{$label}{wait} ) { | ||||
| 65 | 0 | 0 | my $min = $self->{$label}{wait}[0] // 0; | ||||
| 66 | 0 | 0 | my $max = $self->{$label}{wait}[1] // 0; | ||||
| 67 | 0 | 0 | $wait = rand( $max - $min ) + $min; | ||||
| 68 | } | ||||||
| 69 | else { | ||||||
| 70 | 3 | 3 | $wait = $self->{$label}{wait}; | ||||
| 71 | } | ||||||
| 72 | |||||||
| 73 | 3 | 10 | my $sleep = $wait - ( time - $self->{$label}{last} ); | ||||
| 74 | 3 | 7 | sleep($sleep) if ( $sleep > 0 ); | ||||
| 75 | } | ||||||
| 76 | |||||||
| 77 | 5 | 42 | $self->{$label}{last} = time; | ||||
| 78 | 5 | 13 | $self->{$label}{$_} = $input->{$label}{$_} for ( qw( do wait ) ); | ||||
| 79 | |||||||
| 80 | 5 | 20 | push( @{ $self->{history} }, { | ||||
| 81 | label => $label, | ||||||
| 82 | do => $self->{$label}{do}, | ||||||
| 83 | wait => $self->{$label}{wait}, | ||||||
| 84 | 5 | 4 | time => time, | ||||
| 85 | } ); | ||||||
| 86 | |||||||
| 87 | 5 | 7 | $self->{$label}{do}->(); | ||||
| 88 | } | ||||||
| 89 | } | ||||||
| 90 | |||||||
| 91 | sub now { | ||||||
| 92 | 1 | 1 | 4 | return time; | |||
| 93 | } | ||||||
| 94 | |||||||
| 95 | sub last { | ||||||
| 96 | 2 | 1 | 4 | my ( $self, $label ) = @_; | |||
| 97 | 2 | 7 | return ( defined $label ) ? $self->{$label}{last} : $self->history( undef, 1 )->[0]{time}; | ||||
| 98 | } | ||||||
| 99 | |||||||
| 100 | sub history { | ||||||
| 101 | 4 | 1 | 5 | my ( $self, $label, $last ) = @_; | |||
| 102 | |||||||
| 103 | 4 | 5 | my $history = $self->{history}; | ||||
| 104 | 4 10 | 9 14 | $history = [ grep { $_->{label} eq $label } @$history ] if ($label); | ||||
| 105 | 4 4 | 9 6 | $history = [ grep { defined } @$history[ @$history - $last - 1, @$history - 1 ] ] if ( defined $last ); | ||||
| 106 | |||||||
| 107 | 4 | 15 | return $history; | ||||
| 108 | } | ||||||
| 109 | |||||||
| 110 | 1; | ||||||