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