File Coverage

blib/lib/Retry/Backoff.pm
Criterion Covered Total %
statement 74 78 94.8
branch 27 32 84.3
condition 6 9 66.6
subroutine 9 9 100.0
pod 1 3 33.3
total 117 131 89.3


line stmt bran cond sub pod time code
1             package Retry::Backoff;
2              
3 1     1   55460 use 5.010001;
  1         13  
4 1     1   5 use strict 'subs', 'vars';
  1         2  
  1         22  
5 1     1   4 use warnings;
  1         1  
  1         32  
6 1     1   1494 use Log::ger;
  1         42  
  1         4  
7              
8 1     1   232 use Exporter 'import';
  1         2  
  1         25  
9 1     1   1041 use Time::HiRes qw(time);
  1         1170  
  1         3  
10              
11             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
12             our $DATE = '2023-01-08'; # DATE
13             our $DIST = 'Retry-Backoff'; # DIST
14             our $VERSION = '0.005'; # VERSION
15              
16             our @EXPORT_OK = qw(retry);
17              
18             sub new {
19 10     10 0 13 my $class = shift;
20 10         23 my %args = @_;
21              
22 10         13 my $self = {};
23              
24 10         17 $self->{strategy} = delete $args{strategy};
25 10 100       22 unless ($self->{strategy}) {
26 9         14 $self->{strategy} = 'Exponential';
27 9   50     21 $args{initial_delay} //= 1;
28 9   100     31 $args{max_attempts} //= 10;
29 9   50     26 $args{max_delay} //= 300;
30             }
31 10         23 $self->{on_failure} = delete $args{on_failure};
32 10         13 $self->{on_success} = delete $args{on_success};
33 10         13 $self->{retry_if} = delete $args{retry_if};
34 10         14 $self->{non_blocking} = delete $args{non_blocking};
35 10         13 $self->{attempt_code} = delete $args{attempt_code};
36 10         18 $self->{on_final_failure} = delete $args{on_final_failure};
37              
38 10         15 my $ba_mod = "Algorithm::Backoff::$self->{strategy}";
39 10         46 (my $ba_mod_pm = "$ba_mod.pm") =~ s!::!/!g;
40 10         955 require $ba_mod_pm;
41 10         2711 $self->{_backoff} = $ba_mod->new(%args);
42              
43 10         561 bless $self, $class;
44             }
45              
46             sub run {
47 10     10 0 15 my $self = shift;
48              
49 10         14 my @attempt_result;
50             my $attempt_result;
51 10         16 my $wantarray = wantarray;
52              
53 10         10 while(1) {
54 19 50       48 if (my $timestamp = $self->{_needs_sleeping_until}) {
55             # we can't retry until we have waited enough time
56 0         0 my $now = time();
57 0 0       0 $now >= $timestamp or return;
58 0         0 $self->{_needs_sleeping_until} = 0;
59             }
60              
61             # run the code, capture the error
62 19         20 my $error;
63 19 100       41 if ($wantarray) {
    100          
64 3         5 $wantarray = 1;
65 3         4 @attempt_result = eval { $self->{attempt_code}->(@_) };
  3         7  
66 3         23 $error = $@;
67             } elsif (!defined $wantarray) {
68 13         16 eval { $self->{attempt_code}->(@_) };
  13         30  
69 13         72 $error = $@;
70             } else {
71 3         5 $attempt_result = eval { $self->{attempt_code}->(@_) };
  3         8  
72 3         30 $error = $@;
73             }
74              
75 19 100       70 my $h = {
76             error => $error,
77             action_retry => $self,
78             attempt_result =>
79             ( $wantarray ? \@attempt_result : $attempt_result ),
80             attempt_parameters => \@_,
81             };
82              
83 19 100       42 if ($self->{retry_if}) {
84 2         4 $error = $self->{retry_if}->($h);
85             }
86              
87 19         26 my $delay;
88 19         36 my $now = time();
89 19 100       30 if ($error) {
90 12 100       29 $self->{on_failure}->($h) if $self->{on_failure};
91 12         33 $delay = $self->{_backoff}->failure($now);
92             } else {
93 7 100       34 $self->{on_success}->($h) if $self->{on_success};
94 7         25 $delay = $self->{_backoff}->success($now);
95             }
96              
97 19 100       496 if ($delay == -1) {
    50          
98 3 100 66     11 $self->{on_final_failure}->($h) if $self->{on_final_failure} && $error;
99 3         10 last;
100             } elsif ($self->{non_blocking}) {
101 0         0 $self->{_needs_sleeping_until} = $now + $delay;
102             } else {
103 16         1235 sleep $delay;
104             }
105              
106 16 100       91 last unless $error;
107             }
108              
109 10 100       39 return $wantarray ? @attempt_result : $attempt_result;
110             }
111              
112              
113             sub retry (&;@) { ## no critic: Subroutines::ProhibitSubroutinePrototypes
114 10     10 1 24162 my $code = shift;
115 10 50       31 @_ % 2
116             and die "Arguments to retry must be a CodeRef, and an even number of key / values";
117 10         26 my %args = @_;
118 10         34 __PACKAGE__->new(attempt_code => $code, %args)->run();
119             }
120              
121             1;
122             # ABSTRACT: Retry a piece of code, with backoff strategies
123              
124             __END__