File: | lib/Time/DoAfter.pm |
Coverage: | 86.2% |
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 4 24 | use strict; | ||||
5 | 1 1 1 | 3 1 25 | use warnings; | ||||
6 | |||||||
7 | 1 1 1 | 3 1 53 | use Carp 'croak'; | ||||
8 | 1 1 1 | 3 1 85 | use Time::HiRes qw( time sleep ); | ||||
9 | |||||||
10 | # VERSION | ||||||
11 | |||||||
12 | sub _input_handler { | ||||||
13 | 9 | 11 | my ( $input, $set ) = ( {}, {} ); | ||||
14 | |||||||
15 | my $push_input = sub { | ||||||
16 | $input->{ $set->{label} || '_label' } = { | ||||||
17 | wait => $set->{wait}, | ||||||
18 | do => $set->{do}, | ||||||
19 | 13 | 43 | }; | ||||
20 | 13 | 10 | $set = {}; | ||||
21 | 9 | 20 | }; | ||||
22 | |||||||
23 | 9 | 13 | while (@_) { | ||||
24 | 19 | 16 | my $thing = shift; | ||||
25 | 19 | 143 | 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 | 19 | 23 | croak('Unable to understand input provided; at least one thing provided is not a proper input') | ||||
31 | if ( $type eq 'error' ); | ||||||
32 | |||||||
33 | 19 | 83 | $push_input->() if ( exists $set->{$type} ); | ||||
34 | 19 | 41 | $set->{$type} = $thing; | ||||
35 | } | ||||||
36 | |||||||
37 | 9 | 10 | $push_input->(); | ||||
38 | 9 | 28 | return $input; | ||||
39 | } | ||||||
40 | |||||||
41 | { | ||||||
42 | my $singleton; | ||||||
43 | |||||||
44 | sub new { | ||||||
45 | 4 | 1 | 13 | if ($singleton) { | |||
46 | 3 | 5 | my $input = _input_handler(@_); | ||||
47 | 3 | 11 | $singleton->{$_} = $input->{$_} for ( keys %$input ); | ||||
48 | 3 | 12 | return $singleton; | ||||
49 | } | ||||||
50 | |||||||
51 | 1 | 1 | shift; | ||||
52 | |||||||
53 | 1 | 3 | my $self = bless( _input_handler(@_), __PACKAGE__ ); | ||||
54 | 1 | 1 | $singleton = $self; | ||||
55 | 1 | 5 | return $self; | ||||
56 | } | ||||||
57 | } | ||||||
58 | |||||||
59 | sub do { | ||||||
60 | 5 | 1 | 6 | my $self = shift; | |||
61 | 5 | 6 | my $input = _input_handler(@_); | ||||
62 | 5 | 3 | my $total_wait = 0; | ||||
63 | |||||||
64 | 5 | 9 | for my $label ( keys %$input ) { | ||||
65 | 5 | 24 | $input->{$label}{wait} //= $self->{$label}{wait} // 0; | ||||
66 | 5 | 17 | $input->{$label}{do} ||= $self->{$label}{do} || sub {}; | ||||
67 | |||||||
68 | 5 | 7 | if ( $self->{$label}{last} ) { | ||||
69 | 3 | 4 | my $wait; | ||||
70 | 3 | 4 | if ( ref $self->{$label}{wait} ) { | ||||
71 | 0 | 0 | my $min = $self->{$label}{wait}[0] // 0; | ||||
72 | 0 | 0 | my $max = $self->{$label}{wait}[1] // 0; | ||||
73 | 0 | 0 | $wait = rand( $max - $min ) + $min; | ||||
74 | } | ||||||
75 | else { | ||||||
76 | 3 | 3 | $wait = $self->{$label}{wait}; | ||||
77 | } | ||||||
78 | |||||||
79 | 3 | 6 | my $sleep = $wait - ( time - $self->{$label}{last} ); | ||||
80 | 3 | 7 | if ( $sleep > 0 ) { | ||||
81 | 0 | 0 | $total_wait += $sleep; | ||||
82 | 0 | 0 | sleep($sleep); | ||||
83 | } | ||||||
84 | } | ||||||
85 | |||||||
86 | 5 | 53 | $self->{$label}{last} = time; | ||||
87 | 5 | 26 | $self->{$label}{$_} = $input->{$label}{$_} for ( qw( do wait ) ); | ||||
88 | |||||||
89 | 5 | 19 | push( @{ $self->{history} }, { | ||||
90 | label => $label, | ||||||
91 | do => $self->{$label}{do}, | ||||||
92 | wait => $self->{$label}{wait}, | ||||||
93 | 5 | 4 | time => time, | ||||
94 | } ); | ||||||
95 | |||||||
96 | 5 | 7 | $self->{$label}{do}->(); | ||||
97 | } | ||||||
98 | |||||||
99 | 5 | 18 | return $total_wait; | ||||
100 | } | ||||||
101 | |||||||
102 | sub now { | ||||||
103 | 1 | 1 | 5 | return time; | |||
104 | } | ||||||
105 | |||||||
106 | sub last { | ||||||
107 | 4 | 1 | 4 | my ( $self, $label, $time ) = @_; | |||
108 | |||||||
109 | 4 | 26 | my $value_ref = ( defined $label ) ? \$self->{$label}{last} : \$self->history( undef, 1 )->[0]{time}; | ||||
110 | 4 | 8 | $$value_ref = $time if ( defined $time ); | ||||
111 | |||||||
112 | 4 | 13 | return $$value_ref; | ||||
113 | } | ||||||
114 | |||||||
115 | sub history { | ||||||
116 | 4 | 1 | 7 | my ( $self, $label, $last ) = @_; | |||
117 | |||||||
118 | 4 | 5 | my $history = $self->{history}; | ||||
119 | 4 10 | 9 16 | $history = [ grep { $_->{label} eq $label } @$history ] if ($label); | ||||
120 | 4 4 | 11 6 | $history = [ grep { defined } @$history[ @$history - $last - 1, @$history - 1 ] ] if ( defined $last ); | ||||
121 | |||||||
122 | 4 | 14 | return $history; | ||||
123 | } | ||||||
124 | |||||||
125 | sub sub { | ||||||
126 | 3 | 1 | 5 | my ( $self, $label, $sub ) = @_; | |||
127 | |||||||
128 | 3 | 6 | my $value_ref = ( defined $label ) ? \$self->{$label}{do} : \$self->history( undef, 1 )->[0]{do}; | ||||
129 | 3 | 8 | $$value_ref = $sub if ( ref $sub eq 'CODE' ); | ||||
130 | |||||||
131 | 3 | 8 | return $$value_ref; | ||||
132 | } | ||||||
133 | |||||||
134 | sub wait { | ||||||
135 | 3 | 1 | 5 | my ( $self, $label, $wait ) = @_; | |||
136 | |||||||
137 | 3 | 9 | my $value_ref = ( defined $label ) ? \$self->{$label}{wait} : \$self->history( undef, 1 )->[0]{wait}; | ||||
138 | 3 | 7 | $$value_ref = $wait if ( defined $wait ); | ||||
139 | |||||||
140 | 3 | 13 | return $$value_ref; | ||||
141 | } | ||||||
142 | |||||||
143 | 1; |