File Coverage

blib/lib/Try/ALRM.pm
Criterion Covered Total %
statement 51 55 92.7
branch 9 12 75.0
condition 9 13 69.2
subroutine 13 14 92.8
pod 6 6 100.0
total 88 100 88.0


line stmt bran cond sub pod time code
1 5     5   341285 use strict;
  5         44  
  5         145  
2 5     5   25 use warnings;
  5         14  
  5         288  
3              
4             package Try::ALRM;
5              
6             our $VERSION = q{0.8};
7              
8 5     5   40 use Exporter qw/import/;
  5         12  
  5         3425  
9             our @EXPORT = qw(try_once retry ALRM finally timeout tries);
10             our @EXPORT_OK = qw(try_once retry ALRM finally timeout tries);
11              
12             our $TIMEOUT = 60;
13             our $TRIES = 3;
14              
15             # setter/getter for $Try::ALRM::TIMEOUT
16             sub timeout (;$) {
17 51     51 1 736 my $timeout = shift;
18 51 100       195 if ( defined $timeout ) {
19 5         19 _assert_timeout($timeout);
20 5         9 $TIMEOUT = $timeout;
21             }
22 51         462 return $TIMEOUT;
23             }
24              
25             # setter/getter for $Try::ALRM::TRIES
26             sub tries (;$) {
27 43     43 1 109 my $tries = shift;
28 43 100       135 if ( defined $tries ) {
29 1         3 _assert_tries($tries);
30 1         1 $TRIES = $tries;
31             }
32 43         342 return $TRIES;
33             }
34              
35             #NOTE: C a case of C, where C<< tries => 1 >>.
36             sub try_once (&;@) {
37 7     7 1 22 &retry( @_, tries => 1 ); #&retry, bypasses prototype
38             }
39              
40             sub retry(&;@) {
41 11     11 1 38 unshift @_, q{retry}; # adding marker, will be key for this &
42 11         46 my %TODO = @_;
43 11         29 my $TODO = \%TODO;
44              
45 11   50 0   50 my $RETRY = $TODO->{retry} // sub { }; # defaults to no-op
46 11   100     58 my $ALRM = $TODO->{ALRM} // $SIG{ALRM}; # local ALRM defaults to global $SIG{ALRM}
47 11   66     56 my $timeout = $TODO->{timeout} // $TIMEOUT;
48 11   33     43 my $tries = $TODO->{tries} // $TRIES;
49 11   100 6   73 my $FINALLY = $TODO->{finally} // sub { };
50              
51 11         28 local $TIMEOUT = $timeout; # make available to timeout(;$)
52 11         43 local $TRIES = $tries; # make available to tries(;$)
53              
54 11         75 my ( $attempts, $succeeded );
55              
56             TIMED_ATTEMPTS:
57 11         48 for my $attempt ( 1 .. $TRIES ) {
58 15         37 $attempts = $attempt;
59 15         34 my $retry = 0;
60              
61             # NOTE: handler always becomes a local wrapper
62             local $SIG{ALRM} = sub {
63 15     15   72 ++$retry;
64 15 100       291 if ( ref($ALRM) =~ m/^CODE$|::/ ) {
65 11         118 $ALRM->($attempt);
66             }
67 15         366 };
68              
69             # actual alarm code
70 15         149 alarm($timeout);
71 15         88 $RETRY->($attempt);
72 15         5993137 alarm 0;
73 15 50       7617 unless ( $retry == 1 ) {
74 0         0 ++$succeeded;
75 0         0 last;
76             }
77             }
78              
79             # "finally" (defaults to no-op 'sub {}' if block is not defined)
80 11         76 $FINALLY->( $attempts, $succeeded );
81             }
82              
83             sub ALRM (&;@) {
84 7     7 1 32 unshift @_, q{ALRM};
85 7         36 return @_;
86             }
87              
88             sub finally (&;@) {
89 5     5 1 24 unshift @_, q{finally}; # create marker, will be key for &
90 5         31 return @_;
91             }
92              
93             # internal method, validation
94             sub _assert_timeout {
95 5     5   10 my $timeout = shift;
96 5 50       21 if ( int $timeout <= 0 ) {
97 0         0 die qq{timeout must be an integer >= 1!\n};
98             }
99             }
100              
101             # internal method, validation
102             sub _assert_tries {
103 1     1   3 my $timeout = shift;
104 1 50       4 if ( int $timeout <= 0 ) {
105 0           die qq{timeout must be an integer >= 1!\n};
106             }
107             }
108              
109             __PACKAGE__
110              
111             __END__