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; |