line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBIx::Handler; |
2
|
6
|
|
|
6
|
|
14819
|
use strict; |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
131
|
|
3
|
6
|
|
|
6
|
|
17
|
use warnings; |
|
6
|
|
|
|
|
6
|
|
|
6
|
|
|
|
|
209
|
|
4
|
|
|
|
|
|
|
our $VERSION = '0.13'; |
5
|
|
|
|
|
|
|
|
6
|
6
|
|
|
6
|
|
7929
|
use DBI 1.605; |
|
6
|
|
|
|
|
70235
|
|
|
6
|
|
|
|
|
303
|
|
7
|
6
|
|
|
6
|
|
2655
|
use DBIx::TransactionManager 1.09; |
|
6
|
|
|
|
|
12507
|
|
|
6
|
|
|
|
|
118
|
|
8
|
6
|
|
|
6
|
|
25
|
use Carp (); |
|
6
|
|
|
|
|
7
|
|
|
6
|
|
|
|
|
10181
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
0
|
|
|
sub _noop {} |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
*connect = \&new; |
13
|
|
|
|
|
|
|
sub new { |
14
|
0
|
|
|
0
|
1
|
|
my $class = shift; |
15
|
|
|
|
|
|
|
|
16
|
0
|
0
|
|
|
|
|
my $opts = scalar(@_) == 5 ? pop @_ : +{}; |
17
|
|
|
|
|
|
|
bless { |
18
|
|
|
|
|
|
|
_connect_info => [@_], |
19
|
|
|
|
|
|
|
_pid => undef, |
20
|
|
|
|
|
|
|
_dbh => undef, |
21
|
|
|
|
|
|
|
trace_query => $opts->{trace_query} || 0, |
22
|
|
|
|
|
|
|
trace_ignore_if => $opts->{trace_ignore_if} || \&_noop, |
23
|
|
|
|
|
|
|
result_class => $opts->{result_class} || undef, |
24
|
|
|
|
|
|
|
on_connect_do => $opts->{on_connect_do} || undef, |
25
|
|
|
|
|
|
|
on_disconnect_do => $opts->{on_disconnect_do} || undef, |
26
|
|
|
|
|
|
|
no_ping => $opts->{no_ping} || 0, |
27
|
0
|
|
0
|
|
|
|
dbi_class => $opts->{dbi_class} || "DBI", |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
28
|
|
|
|
|
|
|
}, $class; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub _connect { |
32
|
0
|
|
|
0
|
|
|
my $self = shift; |
33
|
|
|
|
|
|
|
|
34
|
0
|
|
|
|
|
|
my $dbh = $self->{_dbh} = $self->{dbi_class}->connect(@{$self->{_connect_info}}); |
|
0
|
|
|
|
|
|
|
35
|
0
|
0
|
|
|
|
|
my $attr = @{$self->{_connect_info}} > 3 ? $self->{_connect_info}->[3] : {}; |
|
0
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
|
37
|
0
|
0
|
0
|
|
|
|
if (DBI->VERSION > 1.613 && !exists $attr->{AutoInactiveDestroy}) { |
38
|
0
|
|
|
|
|
|
$dbh->STORE(AutoInactiveDestroy => 1); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
0
|
0
|
0
|
|
|
|
if (!exists $attr->{RaiseError} && !exists $attr->{HandleError}) { |
42
|
0
|
|
|
|
|
|
$dbh->STORE(RaiseError => 1); |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
|
45
|
0
|
0
|
0
|
|
|
|
if ($dbh->FETCH('RaiseError') && !exists $attr->{PrintError}) { |
46
|
0
|
|
|
|
|
|
$dbh->STORE(PrintError => 0); |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
0
|
|
|
|
|
|
$self->{_pid} = $$; |
50
|
|
|
|
|
|
|
|
51
|
0
|
|
|
|
|
|
$self->_run_on('on_connect_do', $dbh); |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
|
$dbh; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub dbh { |
57
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
58
|
0
|
0
|
|
|
|
|
$self->_seems_connected or $self->_connect; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
sub _ping { |
62
|
0
|
|
|
0
|
|
|
my ($self, $dbh) = @_; |
63
|
0
|
0
|
|
|
|
|
$self->{no_ping} || $dbh->ping; |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub _seems_connected { |
67
|
0
|
|
|
0
|
|
|
my $self = shift; |
68
|
|
|
|
|
|
|
|
69
|
0
|
0
|
|
|
|
|
my $dbh = $self->{_dbh} or return; |
70
|
|
|
|
|
|
|
|
71
|
0
|
0
|
|
|
|
|
if ( $self->{_pid} != $$ ) { |
72
|
0
|
|
|
|
|
|
$dbh->STORE(InactiveDestroy => 1); |
73
|
0
|
|
|
|
|
|
$self->_in_txn_check; |
74
|
0
|
|
|
|
|
|
delete $self->{txn_manager}; |
75
|
0
|
|
|
|
|
|
return; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
0
|
0
|
0
|
|
|
|
unless ($dbh->FETCH('Active') && $self->_ping($dbh)) { |
79
|
0
|
|
|
|
|
|
$self->_in_txn_check; |
80
|
0
|
|
|
|
|
|
$self->_disconnect; |
81
|
0
|
|
|
|
|
|
return; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
0
|
|
|
|
|
|
$dbh; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub disconnect { |
88
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
89
|
|
|
|
|
|
|
|
90
|
0
|
0
|
|
|
|
|
$self->_seems_connected or return; |
91
|
0
|
|
|
|
|
|
$self->_disconnect; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
sub _disconnect { |
95
|
0
|
|
|
0
|
|
|
my $self = shift; |
96
|
0
|
0
|
|
|
|
|
my $dbh = delete $self->{_dbh} or return; |
97
|
0
|
|
|
|
|
|
delete $self->{txn_manager}; |
98
|
0
|
|
|
|
|
|
$self->_run_on('on_disconnect_do', $dbh); |
99
|
0
|
|
|
|
|
|
$dbh->STORE(CachedKids => {}); |
100
|
0
|
|
|
|
|
|
$dbh->disconnect; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
sub _run_on { |
104
|
0
|
|
|
0
|
|
|
my ($self, $mode, $dbh) = @_; |
105
|
0
|
0
|
|
|
|
|
if ( my $on_connect_do = $self->{$mode} ) { |
106
|
0
|
0
|
|
|
|
|
if (not ref($on_connect_do)) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
$dbh->do($on_connect_do); |
108
|
|
|
|
|
|
|
} elsif (ref($on_connect_do) eq 'CODE') { |
109
|
0
|
|
|
|
|
|
$on_connect_do->($dbh); |
110
|
|
|
|
|
|
|
} elsif (ref($on_connect_do) eq 'ARRAY') { |
111
|
0
|
|
|
|
|
|
$dbh->do($_) for @$on_connect_do; |
112
|
|
|
|
|
|
|
} else { |
113
|
0
|
|
|
|
|
|
Carp::croak("Invalid $mode: ".ref($on_connect_do)); |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
0
|
|
|
0
|
|
|
sub DESTROY { $_[0]->disconnect } |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub result_class { |
121
|
0
|
|
|
0
|
1
|
|
my ($self, $result_class) = @_; |
122
|
0
|
0
|
|
|
|
|
$self->{result_class} = $result_class if $result_class; |
123
|
0
|
|
|
|
|
|
$self->{result_class}; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub trace_query { |
127
|
0
|
|
|
0
|
1
|
|
my ($self, $flag) = @_; |
128
|
0
|
0
|
|
|
|
|
$self->{trace_query} = $flag if defined $flag; |
129
|
0
|
|
|
|
|
|
$self->{trace_query}; |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
sub trace_ignore_if { |
133
|
0
|
|
|
0
|
1
|
|
my ($self, $callback) = @_; |
134
|
0
|
0
|
|
|
|
|
$self->{trace_ignore_if} = $callback if defined $callback; |
135
|
0
|
|
|
|
|
|
$self->{trace_ignore_if}; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub no_ping { |
139
|
0
|
|
|
0
|
1
|
|
my ($self, $enable) = @_; |
140
|
0
|
0
|
|
|
|
|
$self->{no_ping} = $enable if defined $enable; |
141
|
0
|
|
|
|
|
|
$self->{no_ping}; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub query { |
145
|
0
|
|
|
0
|
1
|
|
my ($self, $sql, @args) = @_; |
146
|
|
|
|
|
|
|
|
147
|
0
|
|
|
|
|
|
my $bind; |
148
|
0
|
0
|
|
|
|
|
if (ref($args[0]) eq 'HASH') { |
149
|
0
|
|
|
|
|
|
($sql, $bind) = $self->replace_named_placeholder($sql, $args[0]); |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
else { |
152
|
0
|
0
|
|
|
|
|
$bind = ref($args[0]) eq 'ARRAY' ? $args[0] : \@args; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
0
|
|
|
|
|
|
$sql = $self->trace_query_set_comment($sql); |
156
|
|
|
|
|
|
|
|
157
|
0
|
|
|
|
|
|
my $sth; |
158
|
0
|
|
|
|
|
|
eval { |
159
|
0
|
|
|
|
|
|
$sth = $self->dbh->prepare($sql); |
160
|
0
|
0
|
|
|
|
|
$sth->execute(@{$bind || []}); |
|
0
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
}; |
162
|
0
|
0
|
|
|
|
|
if (my $error = $@) { |
163
|
0
|
|
|
|
|
|
Carp::croak($error); |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
0
|
|
|
|
|
|
my $result_class = $self->result_class; |
167
|
0
|
0
|
|
|
|
|
$result_class ? $result_class->new($self, $sth) : $sth; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub replace_named_placeholder { |
171
|
0
|
|
|
0
|
0
|
|
my ($self, $sql, $args) = @_; |
172
|
|
|
|
|
|
|
|
173
|
0
|
|
|
|
|
|
my %named_bind = %{$args}; |
|
0
|
|
|
|
|
|
|
174
|
0
|
|
|
|
|
|
my @bind; |
175
|
0
|
|
|
|
|
|
$sql =~ s{:(\w+)}{ |
176
|
0
|
0
|
|
|
|
|
Carp::croak("$1 does not exists in hash") if !exists $named_bind{$1}; |
177
|
0
|
0
|
0
|
|
|
|
if ( ref $named_bind{$1} && ref $named_bind{$1} eq "ARRAY" ) { |
178
|
0
|
|
|
|
|
|
push @bind, @{ $named_bind{$1} }; |
|
0
|
|
|
|
|
|
|
179
|
0
|
|
|
|
|
|
my $tmp = join ',', map { '?' } @{ $named_bind{$1} }; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
180
|
0
|
|
|
|
|
|
"($tmp)"; |
181
|
|
|
|
|
|
|
} else { |
182
|
0
|
|
|
|
|
|
push @bind, $named_bind{$1}; |
183
|
0
|
|
|
|
|
|
'?' |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
}ge; |
186
|
|
|
|
|
|
|
|
187
|
0
|
|
|
|
|
|
return ($sql, \@bind); |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub trace_query_set_comment { |
191
|
0
|
|
|
0
|
1
|
|
my ($self, $sql) = @_; |
192
|
0
|
0
|
|
|
|
|
return $sql unless $self->trace_query; |
193
|
|
|
|
|
|
|
|
194
|
0
|
|
|
|
|
|
my $i = 1; |
195
|
0
|
|
|
|
|
|
while ( my (@caller) = caller($i++) ) { |
196
|
0
|
0
|
|
|
|
|
next if ( $caller[0]->isa( __PACKAGE__ ) ); |
197
|
0
|
0
|
|
|
|
|
next if $self->trace_ignore_if->(@caller); |
198
|
0
|
|
|
|
|
|
my $comment = "$caller[1] at line $caller[2]"; |
199
|
0
|
|
|
|
|
|
$comment =~ s/\*\// /g; |
200
|
0
|
|
|
|
|
|
$sql = "/* $comment */ $sql"; |
201
|
0
|
|
|
|
|
|
last; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
0
|
|
|
|
|
|
$sql; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
sub run { |
208
|
0
|
|
|
0
|
1
|
|
my ($self, $coderef) = @_; |
209
|
0
|
|
|
|
|
|
my $wantarray = wantarray; |
210
|
|
|
|
|
|
|
|
211
|
0
|
|
|
|
|
|
my @ret = eval { |
212
|
0
|
|
|
|
|
|
my $dbh = $self->dbh; |
213
|
0
|
0
|
|
|
|
|
$wantarray ? $coderef->($dbh) : scalar $coderef->($dbh); |
214
|
|
|
|
|
|
|
}; |
215
|
0
|
0
|
|
|
|
|
if (my $error = $@) { |
216
|
0
|
|
|
|
|
|
Carp::croak($error); |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
0
|
0
|
|
|
|
|
$wantarray ? @ret : $ret[0]; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
# -------------------------------------------------------------------------------- |
223
|
|
|
|
|
|
|
# for transaction |
224
|
|
|
|
|
|
|
sub txn_manager { |
225
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
226
|
|
|
|
|
|
|
|
227
|
0
|
|
|
|
|
|
my $dbh = $self->dbh; |
228
|
0
|
|
0
|
|
|
|
$self->{txn_manager} ||= DBIx::TransactionManager->new($dbh); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
sub in_txn { |
232
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
233
|
0
|
0
|
|
|
|
|
return unless $self->{txn_manager}; |
234
|
0
|
|
|
|
|
|
return $self->{txn_manager}->in_transaction; |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
sub _in_txn_check { |
238
|
0
|
|
|
0
|
|
|
my $self = shift; |
239
|
|
|
|
|
|
|
|
240
|
0
|
|
|
|
|
|
my $info = $self->in_txn; |
241
|
0
|
0
|
|
|
|
|
return unless $info; |
242
|
|
|
|
|
|
|
|
243
|
0
|
|
|
|
|
|
my $caller = $info->{caller}; |
244
|
0
|
|
|
|
|
|
my $pid = $info->{pid}; |
245
|
0
|
|
|
|
|
|
Carp::confess("Detected transaction during a connect operation (last known transaction at $caller->[1] line $caller->[2], pid $pid). Refusing to proceed at"); |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub txn_scope { |
249
|
0
|
|
|
0
|
1
|
|
my @caller = caller(); |
250
|
0
|
|
|
|
|
|
$_[0]->txn_manager->txn_scope(caller => \@caller); |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub txn { |
254
|
0
|
|
|
0
|
1
|
|
my ($self, $coderef) = @_; |
255
|
|
|
|
|
|
|
|
256
|
0
|
|
|
|
|
|
my $wantarray = wantarray; |
257
|
0
|
|
|
|
|
|
my $txn = $self->txn_scope; |
258
|
|
|
|
|
|
|
|
259
|
0
|
|
|
|
|
|
my @ret = eval { |
260
|
0
|
|
|
|
|
|
my $dbh = $self->dbh; |
261
|
0
|
0
|
|
|
|
|
$wantarray ? $coderef->($dbh) : scalar $coderef->($dbh); |
262
|
|
|
|
|
|
|
}; |
263
|
|
|
|
|
|
|
|
264
|
0
|
0
|
|
|
|
|
if (my $error = $@) { |
265
|
0
|
|
|
|
|
|
$txn->rollback; |
266
|
0
|
|
|
|
|
|
Carp::croak($error); |
267
|
|
|
|
|
|
|
} else { |
268
|
0
|
|
|
|
|
|
eval { $txn->commit }; |
|
0
|
|
|
|
|
|
|
269
|
0
|
0
|
|
|
|
|
Carp::croak($@) if $@; |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
0
|
0
|
|
|
|
|
$wantarray ? @ret : $ret[0]; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
0
|
|
|
0
|
1
|
|
sub txn_begin { $_[0]->txn_manager->txn_begin } |
276
|
0
|
|
|
0
|
1
|
|
sub txn_rollback { $_[0]->txn_manager->txn_rollback } |
277
|
0
|
|
|
0
|
1
|
|
sub txn_commit { $_[0]->txn_manager->txn_commit } |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
1; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
__END__ |