File Coverage

blib/lib/DBIx/Connector/Retry.pm
Criterion Covered Total %
statement 59 71 83.1
branch 13 18 72.2
condition n/a
subroutine 11 16 68.7
pod 2 3 66.6
total 85 108 78.7


line stmt bran cond sub pod time code
1             package DBIx::Connector::Retry;
2              
3             our $AUTHORITY = 'cpan:GSG';
4             # ABSTRACT: DBIx::Connector with block retry support
5 2     2   388694 use version;
  2         3256  
  2         10  
6             our $VERSION = 'v0.900.3'; # VERSION
7              
8 2     2   160 use strict;
  2         5  
  2         33  
9 2     2   8 use warnings;
  2         3  
  2         42  
10              
11 2     2   1007 use Moo;
  2         19612  
  2         10  
12              
13             extends 'DBIx::Connector', 'Moo::Object';
14              
15 2     2   2585 use Scalar::Util qw( weaken );
  2         4  
  2         104  
16 2     2   1031 use Types::Standard qw( Str Bool HashRef CodeRef Dict Tuple Optional Maybe );
  2         128452  
  2         25  
17 2     2   3615 use Types::Common::Numeric qw( PositiveInt );
  2         21894  
  2         15  
18              
19 2     2   2036 use namespace::clean; # don't export the above
  2         20689  
  2         13  
20              
21             #pod =encoding utf8
22             #pod
23             #pod =head1 SYNOPSIS
24             #pod
25             #pod my $conn = DBIx::Connector::Retry->new(
26             #pod connect_info => [ 'dbi:Driver:database=foobar', $user, $pass, \%args ],
27             #pod retry_debug => 1,
28             #pod max_attempts => 5,
29             #pod );
30             #pod
31             #pod # Keep retrying/reconnecting on errors
32             #pod my ($count) = $conn->run(ping => sub {
33             #pod $_->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
34             #pod $_->selectrow_array('SELECT COUNT(*) FROM foobar WHERE updated = 1');
35             #pod });
36             #pod
37             #pod # Add a simple retry_handler for a manual timeout
38             #pod my $start_time = time;
39             #pod $conn->retry_handler(sub { time <= $start_time + 60 });
40             #pod
41             #pod my ($count) = $conn->txn(fixup => sub {
42             #pod $_->selectrow_array('SELECT COUNT(*) FROM barbaz');
43             #pod });
44             #pod $conn->clear_retry_handler;
45             #pod
46             #pod # Plus everything else in DBIx::Connector
47             #pod
48             #pod =head1 DESCRIPTION
49             #pod
50             #pod DBIx::Connector::Retry is a Moo-based subclass of L that will retry on
51             #pod failures. Most of the interface was modeled after L
52             #pod and adapted for use in DBIx::Connector.
53             #pod
54             #pod =head1 ATTRIBUTES
55             #pod
56             #pod =head2 connect_info
57             #pod
58             #pod An arrayref that contains all of the connection details normally found in the L or
59             #pod L call. This data can be changed, but won't take effect until the next
60             #pod C<$dbh> re-connection cycle.
61             #pod
62             #pod Obviously, this is required.
63             #pod
64             #pod =cut
65              
66             has connect_info => (
67             is => 'rw',
68             # Yes, DBI->connect() is still technically-valid syntax
69             isa => Tuple[ Maybe[Str], Maybe[Str], Maybe[Str], Optional[HashRef] ],
70             required => 1,
71             );
72              
73             #pod =head2 mode
74             #pod
75             #pod This is just like L except that it can be set from within the
76             #pod constructor.
77             #pod
78             #pod Unlike DBIx::Connector, the default is C, not C.
79             #pod
80             #pod =cut
81              
82             has _mode => (
83             is => 'bare', # use DBIx::Connector's accessor
84             isa => Str,
85             init_arg => 'mode',
86             required => 0,
87             default => 'ping',
88             );
89              
90             #pod =head2 disconnect_on_destroy
91             #pod
92             #pod This is just like L except that it can be set
93             #pod from within the constructor.
94             #pod
95             #pod Default is on.
96             #pod
97             #pod =cut
98              
99             has _dond => (
100             is => 'bare', # use DBIx::Connector's accessor
101             isa => Bool,
102             init_arg => 'disconnect_on_destroy',
103             required => 0,
104             default => 1,
105             );
106              
107             #pod =head2 max_attempts
108             #pod
109             #pod The maximum amount of block running attempts before the Connector gives up and dies.
110             #pod
111             #pod Default is 10.
112             #pod
113             #pod =cut
114              
115             has max_attempts => (
116             is => 'rw',
117             isa => PositiveInt,
118             required => 0,
119             default => 10,
120             );
121              
122             #pod =head2 retry_debug
123             #pod
124             #pod If enabled, any retries will output a debug warning with the error message and number
125             #pod of retries.
126             #pod
127             #pod =cut
128              
129             has retry_debug => (
130             is => 'rw',
131             isa => Bool,
132             required => 0,
133             default => 0,
134             lazy => 1,
135             );
136              
137             sub _warn_retry_debug {
138 0     0   0 my $self = shift;
139              
140 0         0 my $current_attempt_count = $self->failed_attempt_count + 1;
141              
142 0         0 warn sprintf(
143             'Retrying %s coderef (attempt %d) after caught exception: %s',
144             $self->execute_method, $current_attempt_count, $self->last_exception
145             );
146             }
147              
148             #pod =head2 retry_handler
149             #pod
150             #pod An optional handler that will be checked on each retry. It will be passed the Connector
151             #pod object as its only input. If the handler returns a true value, retries will continue.
152             #pod A false value will cause the retry loop to immediately rethrow the exception. You can
153             #pod also throw your own, if you prefer.
154             #pod
155             #pod This check is independent of checks for L.
156             #pod
157             #pod The last exception can be inspected as part of the check by looking at L.
158             #pod This is recommended to make sure the failure is actually what you expect it to be.
159             #pod For example:
160             #pod
161             #pod $conn->retry_handler(sub {
162             #pod my $c = shift;
163             #pod my $err = $c->last_exception;
164             #pod $err = $err->error if blessed $err && $err->isa('DBIx::Connector::RollbackError');
165             #pod
166             #pod # only retry on deadlocks or timeouts (only look in the first line
167             #pod # of the error to avoid e.g. accidental matches in a stack trace)
168             #pod $err =~ /^\V*(?:deadlock|timeout)/i;
169             #pod });
170             #pod
171             #pod Default is an always-true coderef.
172             #pod
173             #pod This attribute has the following handles:
174             #pod
175             #pod =head3 clear_retry_handler
176             #pod
177             #pod Sets it back to the always-true default.
178             #pod
179             #pod =cut
180              
181             has retry_handler => (
182             is => 'rw',
183             isa => CodeRef,
184             required => 1,
185             default => sub { sub { 1 } },
186             );
187              
188 0     0 1 0 sub clear_retry_handler { shift->retry_handler(sub { 1 }) }
  0     0   0  
189              
190             #pod =head2 execute_method
191             #pod
192             #pod The current L execution method name being called, which would either be
193             #pod C or C. Since C is not overridden, it would never be encountered. If the
194             #pod connector is not in the middle of DB block execution, this attribute is blank.
195             #pod
196             #pod =cut
197              
198             has execute_method => (
199             is => 'ro',
200             isa => Str,
201             init_arg => undef,
202             writer => '_set_execute_method',
203             default => '',
204             );
205              
206             #pod =head2 failed_attempt_count
207             #pod
208             #pod The number of failed attempts so far. This can be used in the L or
209             #pod checked afterwards. It will be reset on each block run.
210             #pod
211             #pod Not available for initialization.
212             #pod
213             #pod =cut
214              
215             has failed_attempt_count => (
216             is => 'ro',
217             init_arg => undef,
218             writer => '_set_failed_attempt_count',
219             default => 0,
220             lazy => 1,
221             trigger => sub {
222             my ($self, $val) = @_;
223             $self->_die_from_max_attempts if $self->max_attempts <= ( $val || 0 );
224             },
225             );
226              
227             sub _die_from_max_attempts {
228 0     0   0 my $self = shift;
229 0         0 die sprintf (
230             'Reached max_attempts amount of %d, latest exception: %s',
231             $self->max_attempts, $self->last_exception
232             );
233             }
234              
235             #pod =head2 exception_stack
236             #pod
237             #pod The stack of exceptions received so far, as an arrayref. This can be used in the
238             #pod L or checked afterwards. It will be reset on each block run.
239             #pod
240             #pod Not available for initialization.
241             #pod
242             #pod This attribute has the following handles:
243             #pod
244             #pod =head3 last_exception
245             #pod
246             #pod The last exception on the stack.
247             #pod
248             #pod =cut
249              
250             has exception_stack => (
251             is => 'ro',
252             init_arg => undef,
253             clearer => '_reset_exception_stack',
254             default => sub { [] },
255             lazy => 1,
256             );
257              
258 0     0 1 0 sub last_exception { shift->exception_stack->[-1] }
259              
260             #pod =head1 CONSTRUCTORS
261             #pod
262             #pod =head2 new
263             #pod
264             #pod my $conn = DBIx::Connector::Retry->new(
265             #pod connect_info => [ 'dbi:Driver:database=foobar', $user, $pass, \%args ],
266             #pod max_attempts => 5,
267             #pod # ...etc...
268             #pod );
269             #pod
270             #pod # Old-DBI syntax
271             #pod my $conn = DBIx::Connector::Retry->new(
272             #pod 'dbi:Driver:database=foobar', $user, $pass, \%dbi_args,
273             #pod max_attempts => 5,
274             #pod # ...etc...
275             #pod );
276             #pod
277             #pod As this is a L class, it uses the standard Moo constructor. The L
278             #pod should be specified as its own key. The L/L syntax is available,
279             #pod but only as a nicety for compatibility.
280             #pod
281             #pod =cut
282              
283             around BUILDARGS => sub {
284             my ($orig, $class, @args) = @_;
285              
286             # Old-style DBI/DBIx::Connector parameters. Try to fix it up.
287             if (@args && $args[0] && !ref $args[0] && $args[0] =~ /^dbi:/) {
288             my @connect_info = splice(@args, 0, 3); # DBI DSN, UN, PW
289             push @connect_info, shift @args if $args[0] && (ref $args[0]||'') eq 'HASH'; # DBI \%attr, if it exists
290              
291             if ( @args && $args[0] && (my $ref = ref $args[0]) ) {
292             if ($ref eq 'ARRAY') {
293             push @{$args[0]}, ( connect_info => \@connect_info );
294             @args = @{$args[0]}; # Moo::Object::BUILDARGS doesn't actually support lone ARRAYREFs
295             }
296             elsif ($ref eq 'HASH') {
297             $args[0]{connect_info} = \@connect_info;
298             }
299             else {
300             # Mimicing Moo::Object::BUILDARGS here
301             Carp::croak(join ' ',
302             "The new() method for $class cannot parse the strange argument list.",
303             "Please switch to a standard Moo constructor, instead of the DBI syntax.",
304             );
305             }
306             }
307             else {
308             # either the key within a list or we're out of arguments
309             push @args, ( connect_info => \@connect_info );
310             }
311             }
312              
313             return $class->$orig(@args);
314             };
315              
316             sub BUILD {
317 12     12 0 926 my ($self, $args) = @_;
318              
319 12         26 my @connect_args = @{ $self->connect_info };
  12         178  
320              
321             # Add in the keys that DBIx::Connector expects. For the purposes of future
322             # expandability of DBIx::Connector, we do this by getting a new base Connector
323             # object, and inject those properties into our own object.
324              
325 12         99 my $base_obj = DBIx::Connector->new(@connect_args);
326 12         182 %$self = (
327             %$base_obj,
328             %$self, # $self's existing attributes take priority
329             );
330              
331             # DBIx::Connector stores connection details in a coderef (for some reason). Instead
332             # of just dumping the same arguments as another copy, we'll tie it directly to the
333             # attr. If connect_info ever changes, it will grab the latest version.
334 12     8   70 $self->{_args} = sub { @{ $self->connect_info } };
  8         235  
  8         125  
335 12         53 weaken $self; # circular closure ref
336             }
337              
338             #pod =head1 MODIFIED METHODS
339             #pod
340             #pod =head2 run / txn
341             #pod
342             #pod my @result = $conn->run($mode => $coderef);
343             #pod my $result = $conn->run($mode => $coderef);
344             #pod $conn->run($mode => $coderef);
345             #pod
346             #pod my @result = $conn->txn($mode => $coderef);
347             #pod my $result = $conn->txn($mode => $coderef);
348             #pod $conn->txn($mode => $coderef);
349             #pod
350             #pod Both L and L are modified to run inside
351             #pod a retry loop. If the original Connector action dies, the exception is caught, and if
352             #pod L and L allows it, the action is retried. The database
353             #pod handle may be reset by the Connector action, according to its connection mode.
354             #pod
355             #pod See L for important behaviors/limitations.
356             #pod
357             #pod =cut
358              
359             foreach my $method (qw< run txn >) {
360             around $method => sub {
361             my $orig = shift;
362             my $self = shift;
363             my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift;
364             my $cref = shift;
365              
366             my $wantarray = wantarray;
367              
368             return $self->_retry_loop($orig, $method, $mode, $cref, $wantarray);
369             };
370             }
371              
372             sub _retry_loop {
373 35     35   96 my ($self, $orig, $method, $mode, $cref, $wantarray) = @_;
374              
375             # For the purposes of nesting, these variables should be localized.
376 35         108 local $self->{exception_stack} = [];
377 35         79 local $self->{failed_attempt_count} = 0;
378 35         67 local $self->{execute_method} = $method;
379              
380             # If we already started in a transaction, that implies nesting, so don't
381             # retry the query. We can't guarantee that the statements before the block
382             # run will be committed, and are assuming that the connection will break.
383             #
384             # We cannot rely on checking the database connection via ping, because some
385             # DBDs (like mysql) will try to reconnect to the DB if the first ping check
386             # fails, and a reconnection auto-rollbacks all transactions, locks, etc.
387 35 100       111 if ($self->in_txn) {
388 25 0       192 unless (defined $wantarray) { return $self->$orig($mode, $cref) }
  25 50       60  
389 0         0 elsif ($wantarray) { return ($self->$orig($mode, $cref)) }
  0         0  
390 0         0 else { return scalar $self->$orig($mode, $cref) }
391             }
392              
393             # Mode is localized within $orig, but we should localize it again ourselves, in case
394             # it's changed on-the-fly.
395 10         158 local $self->{_mode} = $mode;
396              
397 10         24 my $run_err;
398             my @res;
399              
400 10         20 do {
401             TRY: {
402             ### NOTE: Outside exception handlers shouldn't interrupt the retry process, as it might
403             ### never return back from the eval. However, if we need to die after the retry_handler
404             ### check below, that should still go to whatever exception handler is in place.
405             ### Therefore, this "local $SIG{__DIE__}" is exactly in this TRY block and expires after
406             ### the DB error is captured.
407 34         183 local $SIG{__DIE__};
  34         108  
408 34         51 local $@;
409              
410 34         55 eval {
411 34 100       71 unless (defined $wantarray) { $self->$orig($mode, $cref) }
  32 100       85  
412 0         0 elsif ($wantarray) { @res = $self->$orig($mode, $cref) }
  1         5  
413 1         5 else { $res[0] = $self->$orig($mode, $cref) }
414             };
415 34         591915 $run_err = $@;
416             }
417              
418 34 100       141 if ($run_err) {
419 24         48 push @{ $self->exception_stack }, $run_err;
  24         424  
420              
421             # This will throw if max_attempts is reached
422 24         468 $self->_set_failed_attempt_count($self->failed_attempt_count + 1);
423              
424             # If the retry handler says no, then die
425 24 50       468 die $run_err unless $self->retry_handler->($self);
426              
427             # Debug line
428 24 50       492 $self->_warn_retry_debug if $self->retry_debug;
429             }
430             } while ($run_err);
431              
432 10 100       165 return $wantarray ? @res : $res[0];
433             }
434              
435             #pod =head1 CAVEATS
436             #pod
437             #pod =head2 $dbh settings
438             #pod
439             #pod Like L, it's important that the L properties have sane
440             #pod connection settings.
441             #pod
442             #pod L should be turned on. Otherwise, the connection is
443             #pod considered to be already in a transaction, and no retries will be attempted. Instead,
444             #pod use transactions via L.
445             #pod
446             #pod L should also be turned on, since exceptions are captured,
447             #pod and both Retry and Connector use them to determine if any of the C<$dbh> calls failed.
448             #pod
449             #pod =head2 Savepoints and nested transactions
450             #pod
451             #pod L is NOT modified to work inside of a retry loop,
452             #pod because retries are generally not possible for savepoints, and a disconnected connection
453             #pod will rollback any uncommited statements in most RDBMS. The same goes for any C/C
454             #pod calls attempted inside of a transaction.
455             #pod
456             #pod Consider the following:
457             #pod
458             #pod # If this dies, sub will retry
459             #pod $conn->txn(ping => sub {
460             #pod shift->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
461             #pod
462             #pod # If this dies, it will not retry
463             #pod $conn->svp(sub {
464             #pod my $c = shift;
465             #pod $c->do('INSERT foobar (name, updated, active) VALUES (?, ?)', undef, 'barbaz', 0, 'off');
466             #pod });
467             #pod });
468             #pod
469             #pod If the savepoint actually tried to retry, the C statement would get rolled back by
470             #pod virtue of database disconnection. However, the savepoint code would continue, possibly
471             #pod even succeeding. You would never know that the C statement was rolled back.
472             #pod
473             #pod However, without savepoint retry support, as it is currently designed, the statements
474             #pod will work as expected. If the savepoint code dies, and if C<$conn> is set up for
475             #pod retries, the transaction code is restarted, after a rollback or reconnection. Thus, the
476             #pod C and C statements are both ran properly if they now succeed.
477             #pod
478             #pod Obviously, this will not work if transactions are manually started outside of the main
479             #pod Connector interface:
480             #pod
481             #pod # Don't do this! The whole transaction isn't compartmentalized properly!
482             #pod $conn->run(ping => sub {
483             #pod $_->begin_work; # don't ever call this!
484             #pod $_->do('UPDATE foobar SET updated = 1 WHERE active = ?', undef, 'on');
485             #pod });
486             #pod
487             #pod # If this dies, the whole app will probably crash
488             #pod $conn->svp(sub {
489             #pod my $c = shift;
490             #pod $c->do('INSERT foobar (name, updated, active) VALUES (?, ?)', undef, 'barbaz', 0, 'off');
491             #pod });
492             #pod
493             #pod # Don't do this!
494             #pod $conn->run(ping => sub {
495             #pod $_->commit; # no, let Connector handle this process!
496             #pod });
497             #pod
498             #pod =head2 (Ab)using $dbh directly
499             #pod
500             #pod For maximum retry protection, do not use the L or
501             #pod L methods directly. Directly accessing and using a DBI
502             #pod database or statement handle does NOT grant retry protection, even if it was acquired
503             #pod from those methods. Furthermore, using those methods may trigger a connection failure,
504             #pod which isn't protected by C.
505             #pod
506             #pod Instead, only use the C/C methods, and it will attempt the connection for you.
507             #pod If the connection fails, retry protection kicks in, as it's part of the same retry loop.
508             #pod
509             #pod =head2 Fixup mode
510             #pod
511             #pod Because of the nature of L, the block may be
512             #pod executed twice as often. Functionally, the code looks like this:
513             #pod
514             #pod # Very simplified example
515             #pod sub fixup_run {
516             #pod my ($self, $code) = @_;
517             #pod
518             #pod my (@ret, $run_err);
519             #pod do {
520             #pod eval {
521             #pod @ret = eval { $code->($dbh) };
522             #pod my $err = $@;
523             #pod
524             #pod if ($err) {
525             #pod die $err if $self->connected;
526             #pod # Not connected. Try again.
527             #pod return $code->($dbh);
528             #pod }
529             #pod };
530             #pod $run_err = $@;
531             #pod
532             #pod if ($run_err) {
533             #pod # Push exception_stack, set/check attempts, check retry_handler
534             #pod }
535             #pod } while ($run_err);
536             #pod return @ret;
537             #pod }
538             #pod
539             #pod If the first eval dies because of a connection failure, the code is ran twice before the
540             #pod retry loop finds it. This is only considered to be one attempt. If it dies because of
541             #pod some other fault, it's only ran once and continues the retry loop.
542             #pod
543             #pod If this is behavior is undesirable, this can be worked around by using the L
544             #pod to change the L after the first attempt:
545             #pod
546             #pod $conn->retry_handler(sub {
547             #pod my $c = shift;
548             #pod $c->mode('ping') if $c->mode eq 'fixup';
549             #pod 1;
550             #pod });
551             #pod
552             #pod Mode is localized outside of the retry loop, so even C<< $conn->run(fixup => $code) >>
553             #pod calls work, and the default mode will return to normal after the block run.
554             #pod
555             #pod =head1 SEE ALSO
556             #pod
557             #pod L, L
558             #pod
559             #pod =cut
560              
561             1;
562              
563             __END__