line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBIx::RetryOverDisconnects; |
2
|
1
|
|
|
1
|
|
20689
|
use base 'DBI'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2716
|
|
3
|
1
|
|
|
1
|
|
26665
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
36
|
|
4
|
1
|
|
|
1
|
|
21
|
use 5.006; |
|
1
|
|
|
|
|
11
|
|
|
1
|
|
|
|
|
69
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
our $VERSION = '0.12'; |
7
|
|
|
|
|
|
|
our ($errstr, $err); |
8
|
1
|
|
|
1
|
|
1269
|
use Exception::Class qw(DBIx::RetryOverDisconnects::Exception); |
|
1
|
|
|
|
|
13455
|
|
|
1
|
|
|
|
|
6
|
|
9
|
|
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->Trace(1); |
10
|
1
|
|
|
1
|
|
225
|
use constant PRIV => 'private_DBIx-RetryOverDisconnects_data'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
301
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 NAME |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
DBIx::RetryOverDisconnects - DBI wrapper that helps to deal with databases connection problems |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=head1 SYNOPSIS |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
use DBIx::RetryOverDisconnects; |
19
|
|
|
|
|
|
|
my $dbh = DBIx::RetryOverDisconnects->connect($dsn, $user, $pass, { |
20
|
|
|
|
|
|
|
ReconnectRetries => 5, |
21
|
|
|
|
|
|
|
ReconnectInterval => 1, |
22
|
|
|
|
|
|
|
ReconnectTimeout => 3, |
23
|
|
|
|
|
|
|
TxnRetries => 3, |
24
|
|
|
|
|
|
|
}); |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
#All of this 3 methods will be successfuly completed despite of |
27
|
|
|
|
|
|
|
#possible connection losses except for sql errors. |
28
|
|
|
|
|
|
|
$dbh->do("..."); |
29
|
|
|
|
|
|
|
my $sth = $dbh->prepare("..."); |
30
|
|
|
|
|
|
|
$sth->execute(...); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
#other functionality that DBI supports |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
$dbh->begin_work; |
35
|
|
|
|
|
|
|
my $ok = eval { |
36
|
|
|
|
|
|
|
$dbh->do("..."); |
37
|
|
|
|
|
|
|
#...code |
38
|
|
|
|
|
|
|
$dbh->do("..."); |
39
|
|
|
|
|
|
|
$dbh->commit; |
40
|
|
|
|
|
|
|
1; |
41
|
|
|
|
|
|
|
}; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
unless ($ok) { |
44
|
|
|
|
|
|
|
if ($dbh->is_trans_disconnect) { |
45
|
|
|
|
|
|
|
#connection to database has been lost during transaction |
46
|
|
|
|
|
|
|
#$dbh has been already reconnected to database as we felt here. |
47
|
|
|
|
|
|
|
#It is now safe to retry the transaction from the beginning. |
48
|
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
|
elsif($dbh->is_fatal_disconnect) { |
50
|
|
|
|
|
|
|
#database is down and reconnect retries limit is reached |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
elsif($dbh->is_sql_error) { |
53
|
|
|
|
|
|
|
#all other DBI's errors that are not related to connection problems |
54
|
|
|
|
|
|
|
$dbh->rollback; |
55
|
|
|
|
|
|
|
#deal with sql error; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
#or simply run the perl code in transaction mode. |
60
|
|
|
|
|
|
|
$dbh->txn_do(sub { |
61
|
|
|
|
|
|
|
$dbh->do("..."); |
62
|
|
|
|
|
|
|
#...code |
63
|
|
|
|
|
|
|
$dbh->do("..."); |
64
|
|
|
|
|
|
|
}); |
65
|
|
|
|
|
|
|
#successful completion is guaranteed except for sql or perl errors. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
=head1 DESCRIPTION |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
This wrapper intercepts all requests. If some request fails this module |
70
|
|
|
|
|
|
|
detects the reason of fail. If the reason was database connection problem |
71
|
|
|
|
|
|
|
then wrapper would automatically reconnect and restart the query. Otherwise |
72
|
|
|
|
|
|
|
it would rethrow the exception. |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
If you are not in transaction then you can just do |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
$dbh->do('...'); |
77
|
|
|
|
|
|
|
$sth->execute(...); |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
This might have 2 fatal cases: |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=over |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item * |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
SQL error (a good reason to die). |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=item * |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Reconnect retries limit reached (database is completely down or network failure). |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
=back |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
For example, if the connection to database were lost during 'execute' call, the module |
94
|
|
|
|
|
|
|
would reconnect to database with a timeout 'ReconnectTimeout'. If reconnect failed it |
95
|
|
|
|
|
|
|
would reconnect again 'ReconnectRetries' times with 'ReconnectInterval' interval |
96
|
|
|
|
|
|
|
(in seconds). If reconnect retries limit was reached it would raise an error and |
97
|
|
|
|
|
|
|
$dbh->is_fatal_disconnect would be true. |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
If you are in transaction then even DB disconnect will raise an error. |
100
|
|
|
|
|
|
|
But you can check $dbh->is_trans_disconnect and restart the transaction if it is 'true'. |
101
|
|
|
|
|
|
|
Other possible errors are the same: sql error and reconnect limit. |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
The recommended way of using transactions is |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
$dbh->txn_do($code_ref); |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
because 'txn_do' would automatically restart the transaction if it was failed because |
108
|
|
|
|
|
|
|
of database disconnect. The transaction can be restarted at most 'TxnRetries' times. |
109
|
|
|
|
|
|
|
If 'TxnRetries' limit was reached then error would be raised and |
110
|
|
|
|
|
|
|
$dbh->is_fatal_trans_disconnect set to true. |
111
|
|
|
|
|
|
|
Other error cases are the same as above. |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
'txn_do' would try do to rollback if there was a perl or sql error (no rollback needed |
114
|
|
|
|
|
|
|
when you loose connection to database: DB server already has done it). |
115
|
|
|
|
|
|
|
Rollback is successul when $@ =~ /Rollback OK/; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
Note: For the perfomance reasons, DBI attribute 'RaiseError' is always set to 'true'. |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
=head1 METHODS |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
=head1 Class methods |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=head2 connect |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
DBIx::RetryOverDisconnects->connect($dsn, $user, $pass, $attrs); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
All parameters are passed directly to DBI. |
128
|
|
|
|
|
|
|
Additional $attrs are |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=over |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item * |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
ReconnectRetries - How many times DBIx::RetryOverDisconnects will try to reconnect |
135
|
|
|
|
|
|
|
to database. Default to 5. |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=item * |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
ReconnectInterval - Interval (in seconds) between reconnect attemps. |
140
|
|
|
|
|
|
|
Default to 2. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=item * |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
ReconnectTimeout - Timeout (in seconds) for waiting the database to accept |
145
|
|
|
|
|
|
|
connection (because sometimes DBI->connect can block your application). |
146
|
|
|
|
|
|
|
Default to 5. |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
=item * |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
TxnRetries - How many times the wrapper would try to restart transaction if it was |
151
|
|
|
|
|
|
|
failed because of database connection problems. Default to 4. |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=back |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
=cut |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub connect { |
158
|
0
|
|
|
0
|
1
|
|
my ($this, $dsn, $user, $pass, $attrs) = @_; |
159
|
|
|
|
|
|
|
|
160
|
0
|
|
|
|
|
|
my $self_attrs = $this->get_self_attrs($attrs); |
161
|
0
|
|
|
|
|
|
$attrs->{RaiseError} = 1; |
162
|
0
|
|
|
|
|
|
my $self = $this->SUPER::connect($dsn, $user, $pass, $attrs); |
163
|
0
|
|
|
|
|
|
my $driver = $self->{Driver}{Name}; |
164
|
0
|
0
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new("Sorry, driver '$driver' is not yet supported\n")->throw |
165
|
|
|
|
|
|
|
unless DBIx::RetryOverDisconnects::db->can('is_disconnect_'.lc($driver)); |
166
|
0
|
|
|
|
|
|
$self_attrs->{AutoCommit} = $self->{AutoCommit}; |
167
|
0
|
|
|
|
|
|
$self->{PRIV()} = $self_attrs; |
168
|
|
|
|
|
|
|
|
169
|
0
|
|
|
|
|
|
return $self; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub get_self_attrs { |
173
|
0
|
|
|
0
|
0
|
|
my ($this, $attrs) = @_; |
174
|
|
|
|
|
|
|
return { |
175
|
0
|
0
|
0
|
|
|
|
retries => exists $attrs->{ReconnectRetries} ? (delete $attrs->{ReconnectRetries}) : 5, |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
176
|
|
|
|
|
|
|
interval => (delete $attrs->{ReconnectInterval}) || 1, |
177
|
|
|
|
|
|
|
timeout => (delete $attrs->{ReconnectTimeout}) || 5, |
178
|
|
|
|
|
|
|
txn_retries => (delete $attrs->{TxnRetries}) || 4, |
179
|
|
|
|
|
|
|
}; |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
package DBIx::RetryOverDisconnects::db; |
184
|
1
|
|
|
1
|
|
5
|
use base 'DBI::db'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
586
|
|
185
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
33
|
|
186
|
|
|
|
|
|
|
|
187
|
1
|
|
|
1
|
|
4
|
use constant PRIV => DBIx::RetryOverDisconnects::PRIV(); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
536
|
|
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
sub clone { |
190
|
0
|
|
|
0
|
|
|
my $self = shift; |
191
|
0
|
|
|
|
|
|
local $^W = 0; |
192
|
0
|
|
|
|
|
|
my $data = $self->{PRIV()}; |
193
|
0
|
|
|
|
|
|
$data->{is_cloning} = 1; |
194
|
0
|
0
|
|
|
|
|
my $new_self = $self->SUPER::clone(@_) or return; |
195
|
0
|
|
|
|
|
|
delete $data->{is_cloning}; |
196
|
0
|
|
|
|
|
|
$new_self->{PRIV()} = {%$data}; |
197
|
0
|
|
|
|
|
|
return $new_self; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=head1 Database handle object methods |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=head2 set_callback |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
$dbh->set_callback(afterReconnect => $code_ref); |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
Set callbacks for some events. Currently only afterReconnect is supported. |
207
|
|
|
|
|
|
|
It is called after every successful reconnect to database. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=cut |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub set_callback { |
212
|
0
|
|
|
0
|
|
|
my ($self, %callbacks) = @_; |
213
|
0
|
|
0
|
|
|
|
my $old = $self->{PRIV()}->{callback} || {}; |
214
|
0
|
|
|
|
|
|
$self->{PRIV()}->{callback} = {%$old, %callbacks}; |
215
|
0
|
|
|
|
|
|
return; |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub exc_conn_trans { |
219
|
0
|
|
|
0
|
|
|
my $self = shift; |
220
|
0
|
|
|
|
|
|
my $msg = 'Connection to database lost while in transaction'; |
221
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::errstr = $msg; |
222
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::err = 3; |
223
|
0
|
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new($msg); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub exc_conn_trans_fatal { |
227
|
0
|
|
|
0
|
|
|
my $self = shift; |
228
|
0
|
|
|
|
|
|
my $msg = 'Connection to database lost while in transaction (retries exceeded)'; |
229
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::errstr = $msg; |
230
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::err = 4; |
231
|
0
|
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new($msg); |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
=head2 is_fatal_trans_disconnect |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
Returns 'true' if last failed operation was txn_do and TxnRetries limit |
237
|
|
|
|
|
|
|
was reached. |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
=cut |
240
|
|
|
|
|
|
|
|
241
|
0
|
|
|
0
|
|
|
sub is_fatal_trans_disconnect {$DBIx::RetryOverDisconnects::err == 4} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
=head2 is_trans_disconnect |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
Return 'true' if last failed operation was a transaction and it could be restarted. |
246
|
|
|
|
|
|
|
The database handle was successfuly reconnected again. |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
=cut |
249
|
|
|
|
|
|
|
|
250
|
0
|
|
|
0
|
|
|
sub is_trans_disconnect {$DBIx::RetryOverDisconnects::err == 3} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=head2 is_fatal_disconnect |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
Return 'true' if reconnect retries limit has been reached. In this case the |
255
|
|
|
|
|
|
|
database handle is not connected. |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=cut |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
0
|
|
|
sub is_fatal_disconnect {$DBIx::RetryOverDisconnects::err == 2} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=head2 is_sql_error |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
Return 'true' if query failed because of some other reason, not related to |
264
|
|
|
|
|
|
|
database connection problems. See $DBI::errstr for details. |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
=cut |
267
|
|
|
|
|
|
|
|
268
|
0
|
|
|
0
|
|
|
sub is_sql_error {$DBIx::RetryOverDisconnects::err == 1} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
sub exc_conn_fatal { |
271
|
0
|
|
|
0
|
|
|
my $self = shift; |
272
|
0
|
|
|
|
|
|
my $msg = 'Connection to database lost (retries exceeded)'; |
273
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::errstr = $msg; |
274
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::err = 2; |
275
|
0
|
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new($msg); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
sub exc_flush { |
279
|
0
|
|
|
0
|
|
|
my $self = shift; |
280
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::errstr = undef; |
281
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::err = undef; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
sub exc_std { |
285
|
0
|
|
|
0
|
|
|
my ($self, $e) = @_; |
286
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::errstr = 'standard DBI error'; |
287
|
0
|
|
|
|
|
|
$DBIx::RetryOverDisconnects::err = 1; |
288
|
0
|
|
|
|
|
|
$e; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
foreach my $func (qw/ |
292
|
|
|
|
|
|
|
prepare do statistics_info begin_work commit rollback |
293
|
|
|
|
|
|
|
selectrow_array selectrow_arrayref selectall_arrayref |
294
|
|
|
|
|
|
|
selectall_hashref |
295
|
|
|
|
|
|
|
/) |
296
|
|
|
|
|
|
|
{ |
297
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
1317
|
|
298
|
|
|
|
|
|
|
*$func = sub { |
299
|
0
|
|
|
0
|
|
|
my $self = shift; |
300
|
0
|
|
|
|
|
|
my $super_method = "SUPER::$func"; |
301
|
0
|
|
|
|
|
|
my $data = $self->{PRIV()}; |
302
|
0
|
0
|
|
|
|
|
return $self->$super_method(@_) if $data->{Intercept}; #Already protected |
303
|
|
|
|
|
|
|
|
304
|
0
|
|
|
|
|
|
my ($retval, @retval); |
305
|
0
|
|
|
|
|
|
my $wa = wantarray; |
306
|
0
|
|
|
|
|
|
my $autocommit = $self->{AutoCommit}; |
307
|
|
|
|
|
|
|
|
308
|
0
|
|
|
|
|
|
while(1) { |
309
|
|
|
|
|
|
|
|
310
|
0
|
|
|
|
|
|
$data->{Intercept} = 1; |
311
|
0
|
|
|
|
|
|
local $@; |
312
|
0
|
|
|
|
|
|
my $ok = eval { |
313
|
0
|
0
|
|
|
|
|
defined $wa ? $wa ? (@retval = $self->$super_method(@_)) : |
|
|
0
|
|
|
|
|
|
314
|
|
|
|
|
|
|
($retval = $self->$super_method(@_)) : |
315
|
|
|
|
|
|
|
$self->$super_method(@_); |
316
|
0
|
|
|
|
|
|
1; |
317
|
|
|
|
|
|
|
}; |
318
|
0
|
|
|
|
|
|
$data->{Intercept} = 0; |
319
|
|
|
|
|
|
|
|
320
|
0
|
0
|
|
|
|
|
last if $ok; |
321
|
|
|
|
|
|
|
|
322
|
0
|
|
0
|
|
|
|
my $e = DBIx::RetryOverDisconnects::Exception->new( $DBI::errstr or $@ ); |
323
|
0
|
0
|
|
|
|
|
return unless $self->take_measures($e, undef, $autocommit); |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
0
|
0
|
|
|
|
|
return $wa ? @retval : $retval; |
327
|
|
|
|
|
|
|
}; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
=head2 ping |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
Always returns 'true' or dies ($dbh->is_fatal_disconnect = true). Does original DBI::db's |
333
|
|
|
|
|
|
|
ping and if it is false then it reconnects. |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
=cut |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub ping { |
338
|
0
|
|
|
0
|
|
|
my $self = shift; |
339
|
0
|
0
|
|
|
|
|
return 1 if $self->SUPER::ping; |
340
|
0
|
0
|
|
|
|
|
return if $self->{PRIV()}{is_cloning}; |
341
|
0
|
|
|
|
|
|
my $in_trans = !$self->{AutoCommit}; |
342
|
0
|
|
|
|
|
|
$self->reconnect; |
343
|
0
|
0
|
|
|
|
|
$self->exc_conn_trans->throw if $in_trans; |
344
|
0
|
|
|
|
|
|
return 1; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub take_measures { |
348
|
0
|
|
|
0
|
|
|
my ($self, $e, $sth, $autocommit) = @_; |
349
|
0
|
|
|
|
|
|
$self->exc_flush; |
350
|
0
|
|
|
|
|
|
local $@; |
351
|
0
|
0
|
|
|
|
|
$self->exc_std($e)->rethrow if eval { $self->SUPER::ping }; |
|
0
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
|
353
|
0
|
|
|
|
|
|
my $is_disconnect_method = 'is_disconnect_'.lc($self->{Driver}->{Name}); |
354
|
0
|
0
|
|
|
|
|
if ($self->$is_disconnect_method($e)) { |
355
|
0
|
0
|
|
|
|
|
warn "Disconnected!\n" if $self->{PrintError}; |
356
|
0
|
0
|
|
|
|
|
return unless $self->reconnect($sth); |
357
|
0
|
0
|
|
|
|
|
$self->exc_conn_trans->throw unless $autocommit; |
358
|
0
|
|
|
|
|
|
return 1; |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
0
|
|
|
|
|
|
$self->exc_std($e)->rethrow; |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
sub is_disconnect_mysql { |
365
|
0
|
|
|
0
|
|
|
my $self = shift; |
366
|
0
|
|
|
|
|
|
local $_ = shift; |
367
|
0
|
0
|
0
|
|
|
|
return 1 if /lost\s+connection/i or /can't\s+connect/i or |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
368
|
|
|
|
|
|
|
/server\s+shutdown/i or /MySQL\s+server\s+has\s+gone\s+away/i; |
369
|
0
|
|
|
|
|
|
return; |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
sub is_disconnect_pg { |
373
|
0
|
|
|
0
|
|
|
my $self = shift; |
374
|
0
|
|
|
|
|
|
local $_ = shift; |
375
|
0
|
0
|
0
|
|
|
|
return 1 if /server\s+closed\s+the\s+connection\s+unexpectedly/i or |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
376
|
|
|
|
|
|
|
/terminating connection/ or |
377
|
|
|
|
|
|
|
/no\s+more\s+connections\s+allowed/ or # pgbouncer |
378
|
|
|
|
|
|
|
/no\s+working\s+server\s+connection/ or # pgbouncer 1.4.2 |
379
|
|
|
|
|
|
|
/_timeout/ or # pgbouncer |
380
|
|
|
|
|
|
|
/pgbouncer\s+cannot\s+connect\s+to\s+server/; # pgbouncer 1.5+ |
381
|
0
|
|
|
|
|
|
return; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
*is_disconnect_pgpp = *is_disconnect_pg; |
384
|
|
|
|
|
|
|
|
385
|
0
|
|
|
0
|
|
|
sub is_disconnect_sqlite {} #SQLite has no connection problems. Isn't that right? |
386
|
|
|
|
|
|
|
*is_disconnect_sqlite2 = *is_disconnect_sqlite; |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub is_disconnect_oracle { |
389
|
0
|
|
|
0
|
|
|
my $self = shift; |
390
|
0
|
|
|
|
|
|
local $_ = shift; |
391
|
0
|
0
|
0
|
|
|
|
return 1 if /ORA-03135/ or # "connection lost contact" |
392
|
|
|
|
|
|
|
/ORA-03113/; # "end-of-file on communication channel" |
393
|
0
|
|
|
|
|
|
return; |
394
|
|
|
|
|
|
|
} |
395
|
|
|
|
|
|
|
|
396
|
0
|
|
|
0
|
|
|
sub is_disconnect_sybase { |
397
|
|
|
|
|
|
|
#? |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
|
400
|
0
|
|
|
0
|
|
|
sub is_disconnect_db2 { |
401
|
|
|
|
|
|
|
#? |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
sub reconnect { |
405
|
0
|
|
|
0
|
|
|
my ($self, $sth) = @_; |
406
|
0
|
|
|
|
|
|
my $data = $self->{PRIV()}; |
407
|
0
|
|
|
|
|
|
my $new_dbh; |
408
|
|
|
|
|
|
|
|
409
|
0
|
|
0
|
|
|
|
for (my $i = 1; (!$data->{retries} || $i <= $data->{retries}); $i++) { |
410
|
0
|
0
|
|
|
|
|
warn "Reconnect try #$i\n" if $self->{PrintError}; |
411
|
0
|
|
|
|
|
|
my $alarm; |
412
|
|
|
|
|
|
|
local $SIG{ALRM} = sub { |
413
|
0
|
|
|
0
|
|
|
alarm(0); |
414
|
0
|
|
|
|
|
|
die($alarm = 1); |
415
|
0
|
|
|
|
|
|
}; |
416
|
0
|
|
|
|
|
|
local $@; |
417
|
0
|
|
|
|
|
|
eval { |
418
|
0
|
|
|
|
|
|
alarm($data->{timeout}); |
419
|
0
|
|
|
|
|
|
eval { |
420
|
0
|
|
|
|
|
|
local $^W = 0; |
421
|
0
|
|
|
|
|
|
$new_dbh = $self->clone; |
422
|
|
|
|
|
|
|
}; |
423
|
0
|
|
|
|
|
|
alarm(0); |
424
|
|
|
|
|
|
|
}; |
425
|
0
|
0
|
|
|
|
|
if ($new_dbh) { |
426
|
0
|
0
|
|
|
|
|
warn "Reconnected!\n" if $self->{PrintError}; |
427
|
0
|
|
|
|
|
|
last; |
428
|
|
|
|
|
|
|
} |
429
|
0
|
|
|
|
|
|
sleep $data->{interval}; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
0
|
0
|
|
|
|
|
($self->disconnect, $self->exc_conn_fatal->throw) unless $new_dbh; |
433
|
|
|
|
|
|
|
|
434
|
0
|
|
|
|
|
|
$self->swap_inner_handle($new_dbh); |
435
|
0
|
|
|
|
|
|
$self->{PRIV()} = $data; |
436
|
0
|
|
|
|
|
|
$new_dbh->{PRIV()} = undef; |
437
|
0
|
|
|
|
|
|
$new_dbh->STORE('Active', 0); |
438
|
|
|
|
|
|
|
|
439
|
0
|
|
|
|
|
|
$self->STORE('CachedKids', {}); |
440
|
0
|
0
|
|
|
|
|
if ($sth) { |
441
|
0
|
|
|
|
|
|
my $new_sth = $self->prepare_cached($sth->{Statement}); |
442
|
0
|
|
|
|
|
|
$sth->swap_inner_handle($new_sth, 1); |
443
|
0
|
|
|
|
|
|
$sth->restore_params($new_sth); |
444
|
0
|
|
|
|
|
|
$new_sth->finish; |
445
|
|
|
|
|
|
|
} |
446
|
0
|
|
|
|
|
|
$self->STORE('CachedKids', {}); |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
#Now autocommit is broken (has been copied from disconnected handle) |
449
|
0
|
|
|
|
|
|
$self->{AutoCommit} = $data->{AutoCommit}; #Set initial value |
450
|
0
|
|
|
|
|
|
$new_dbh->disconnect; |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
#Call callback. Currently only one supported. |
453
|
0
|
0
|
0
|
|
|
|
if($self->{PRIV()}{callback} && (my $code = $self->{PRIV()}{callback}{afterReconnect})) { |
454
|
0
|
0
|
|
|
|
|
$code->($self, $sth) if ref $code eq 'CODE'; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
0
|
|
|
|
|
|
return 1; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
=head2 txn_do |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
$dbh->txn_do($code_ref); |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
Executes $code_ref in a transaction environment. Automatically reconnects and |
465
|
|
|
|
|
|
|
restarts the transaction in any case of connection problems. |
466
|
|
|
|
|
|
|
'txn_do' is able to die with one of the is_fatal_disconnect, is_sql_error, |
467
|
|
|
|
|
|
|
is_fatal_trans_disconnect set to true. |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
In most cases you don't need to wrap it into 'eval' because all of this exceptions |
470
|
|
|
|
|
|
|
are subject to die (database completely down, network down, bussiness logic error, etc). |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
=cut |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
sub txn_do { |
475
|
0
|
|
|
0
|
|
|
my ($self, $coderef) = (shift, shift); |
476
|
|
|
|
|
|
|
|
477
|
0
|
0
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new('$coderef must be a CODE reference')->throw |
478
|
|
|
|
|
|
|
unless ref $coderef eq 'CODE'; |
479
|
|
|
|
|
|
|
|
480
|
0
|
0
|
|
|
|
|
return $coderef->(@_) unless $self->{AutoCommit}; |
481
|
|
|
|
|
|
|
|
482
|
0
|
|
|
|
|
|
my $wa = wantarray; |
483
|
0
|
|
|
|
|
|
my (@result, $result); |
484
|
0
|
|
|
|
|
|
my $i = 0; |
485
|
0
|
|
|
|
|
|
while ('preved') { |
486
|
0
|
|
|
|
|
|
local $@; |
487
|
0
|
|
|
|
|
|
my $ok = eval { |
488
|
0
|
|
|
|
|
|
$self->begin_work; |
489
|
0
|
0
|
|
|
|
|
defined $wa ? $wa ? (@result = $coderef->(@_)) : |
|
|
0
|
|
|
|
|
|
490
|
|
|
|
|
|
|
($result = $coderef->(@_)) : |
491
|
|
|
|
|
|
|
$coderef->(@_); |
492
|
0
|
|
|
|
|
|
$self->commit; |
493
|
0
|
|
|
|
|
|
1; |
494
|
|
|
|
|
|
|
}; |
495
|
0
|
0
|
|
|
|
|
last if $ok; |
496
|
|
|
|
|
|
|
|
497
|
0
|
0
|
|
|
|
|
$self->exc_conn_trans_fatal->throw if $self->{PRIV()}{txn_retries} <= $i++; |
498
|
0
|
0
|
|
|
|
|
next if $self->is_trans_disconnect; |
499
|
0
|
0
|
|
|
|
|
$@->rethrow if $self->is_fatal_disconnect; |
500
|
0
|
|
|
|
|
|
my $txn_err = $@; |
501
|
0
|
|
|
|
|
|
my $rollback_ok = eval {$self->rollback; 1}; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
502
|
0
|
0
|
|
|
|
|
$txn_err .= $rollback_ok ? ' (Rollback OK)' : "(Rollback failed: $@)"; |
503
|
0
|
|
|
|
|
|
DBIx::RetryOverDisconnects::Exception->new($txn_err)->throw; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
0
|
0
|
|
|
|
|
return $wa ? @result : $result; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
package DBIx::RetryOverDisconnects::st; |
511
|
1
|
|
|
1
|
|
5
|
use base 'DBI::st'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
445
|
|
512
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
33
|
|
513
|
|
|
|
|
|
|
|
514
|
1
|
|
|
1
|
|
5
|
use constant PRIV => DBIx::RetryOverDisconnects::PRIV(); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
43
|
|
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
foreach my $func (qw/execute execute_array execute_for_fetch/) { |
517
|
1
|
|
|
1
|
|
4
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
428
|
|
518
|
|
|
|
|
|
|
*$func = sub { |
519
|
0
|
|
|
0
|
|
|
my $self = shift; |
520
|
0
|
|
|
|
|
|
my $super_method = "SUPER::$func"; |
521
|
0
|
|
|
|
|
|
my $dbh = $self->{Database}; |
522
|
0
|
|
|
|
|
|
my $data = $dbh->{PRIV()}; |
523
|
0
|
0
|
|
|
|
|
return $self->$super_method(@_) if $data->{Intercept}; #Already protected |
524
|
|
|
|
|
|
|
|
525
|
0
|
|
|
|
|
|
my ($retval, @retval); |
526
|
0
|
|
|
|
|
|
my $wa = wantarray; |
527
|
0
|
|
|
|
|
|
my $autocommit = $dbh->{AutoCommit}; |
528
|
|
|
|
|
|
|
|
529
|
0
|
|
|
|
|
|
while(1) { |
530
|
|
|
|
|
|
|
|
531
|
0
|
|
|
|
|
|
$data->{Intercept} = 1; |
532
|
0
|
|
|
|
|
|
local $@; |
533
|
0
|
|
|
|
|
|
my $ok = eval { |
534
|
0
|
0
|
|
|
|
|
defined $wa ? $wa ? (@retval = $self->$super_method(@_)) : |
|
|
0
|
|
|
|
|
|
535
|
|
|
|
|
|
|
($retval = $self->$super_method(@_)) : |
536
|
|
|
|
|
|
|
$self->$super_method(@_); |
537
|
0
|
|
|
|
|
|
1; |
538
|
|
|
|
|
|
|
}; |
539
|
0
|
|
|
|
|
|
$data->{Intercept} = 0; |
540
|
|
|
|
|
|
|
|
541
|
0
|
0
|
|
|
|
|
last if $ok; |
542
|
|
|
|
|
|
|
|
543
|
0
|
|
0
|
|
|
|
my $e = DBIx::RetryOverDisconnects::Exception->new( $DBI::errstr or $@ ); |
544
|
0
|
0
|
|
|
|
|
return unless $dbh->take_measures($e, $self, $autocommit); |
545
|
|
|
|
|
|
|
} |
546
|
0
|
0
|
|
|
|
|
return $wa ? @retval : $retval; |
547
|
|
|
|
|
|
|
}; |
548
|
|
|
|
|
|
|
} |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
sub restore_params { |
551
|
0
|
|
|
0
|
|
|
my $self = shift; |
552
|
0
|
|
|
|
|
|
my $from = shift; |
553
|
|
|
|
|
|
|
|
554
|
0
|
|
0
|
|
|
|
my $types = $from->{ParamTypes} || {}; |
555
|
|
|
|
|
|
|
#Restore possible ParamArrays |
556
|
0
|
|
0
|
|
|
|
my $param_arrays = $from->{ParamArrays} || {}; |
557
|
0
|
|
|
|
|
|
while (my($bind, $array) = each %$param_arrays) { |
558
|
0
|
0
|
|
|
|
|
$self->bind_param_array($bind, $array, $types->{$bind} ? $types->{$bind} : ()); |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
#Restore normal ph's values |
562
|
0
|
|
0
|
|
|
|
my $param_values = $from->{ParamValues} || {}; |
563
|
0
|
|
|
|
|
|
my $i = 1; |
564
|
0
|
|
|
|
|
|
foreach my $bind_name (sort {($a =~ /(\d+)/)[0] <=> ($b =~ /(\d+)/)[0]} keys %$param_values) { |
|
0
|
|
|
|
|
|
|
565
|
0
|
0
|
|
|
|
|
$self->bind_param($i++, $param_values->{$bind_name}, $types->{$bind_name} ? $types->{$bind_name} : ()); |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=head1 OVERLOADED METHODS |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=head2 Database handle object methods |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
prepare, do, statistics_info, begin_work, commit, rollback, selectrow_array, |
574
|
|
|
|
|
|
|
selectrow_arrayref, selectall_arrayref, selectall_hashref |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
=head2 Database statement object methods |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
execute, execute_array, execute_for_fetch |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
=head1 DATABASE SUPPORT |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
Currently PostgreSQL, MySQL, Oracle and SQLite are supported. |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
=head1 SEE ALSO |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
L, L. |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
=head1 AUTHOR |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
Pronin Oleg |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=head1 LICENSE |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
You may distribute this code under the same terms as Perl itself. |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=cut |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
1; |