line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBI::Gofer::Execute; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $ |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# Copyright (c) 2007, Tim Bunce, Ireland |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public |
8
|
|
|
|
|
|
|
# License or the Artistic License, as specified in the Perl README file. |
9
|
|
|
|
|
|
|
|
10
|
56
|
|
|
56
|
|
390
|
use strict; |
|
56
|
|
|
|
|
122
|
|
|
56
|
|
|
|
|
1723
|
|
11
|
56
|
|
|
56
|
|
284
|
use warnings; |
|
56
|
|
|
|
|
125
|
|
|
56
|
|
|
|
|
1946
|
|
12
|
|
|
|
|
|
|
|
13
|
56
|
|
|
56
|
|
366
|
use Carp; |
|
56
|
|
|
|
|
118
|
|
|
56
|
|
|
|
|
3486
|
|
14
|
|
|
|
|
|
|
|
15
|
56
|
|
|
56
|
|
349
|
use DBI qw(dbi_time); |
|
56
|
|
|
|
|
311
|
|
|
56
|
|
|
|
|
2574
|
|
16
|
56
|
|
|
56
|
|
361
|
use DBI::Gofer::Request; |
|
56
|
|
|
|
|
125
|
|
|
56
|
|
|
|
|
1795
|
|
17
|
56
|
|
|
56
|
|
464
|
use DBI::Gofer::Response; |
|
56
|
|
|
|
|
164
|
|
|
56
|
|
|
|
|
2930
|
|
18
|
|
|
|
|
|
|
|
19
|
56
|
|
|
56
|
|
383
|
use base qw(DBI::Util::_accessor); |
|
56
|
|
|
|
|
136
|
|
|
56
|
|
|
|
|
209319
|
|
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
our $VERSION = "0.014283"; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common}; |
24
|
|
|
|
|
|
|
our %all_dbh_methods = map { $_ => (DBD::_::db->can($_)||undef) } @all_dbh_methods; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
our $current_dbh; # the dbh we're using for this request |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# set trace for server-side gofer |
32
|
|
|
|
|
|
|
# Could use DBI_TRACE env var when it's an unrelated separate process |
33
|
|
|
|
|
|
|
# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream) |
34
|
|
|
|
|
|
|
DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE}; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# define valid configuration attributes (args to new()) |
38
|
|
|
|
|
|
|
# the values here indicate the basic type of values allowed |
39
|
|
|
|
|
|
|
my %configuration_attributes = ( |
40
|
|
|
|
|
|
|
gofer_execute_class => 1, |
41
|
|
|
|
|
|
|
default_connect_dsn => 1, |
42
|
|
|
|
|
|
|
forced_connect_dsn => 1, |
43
|
|
|
|
|
|
|
default_connect_attributes => {}, |
44
|
|
|
|
|
|
|
forced_connect_attributes => {}, |
45
|
|
|
|
|
|
|
track_recent => 1, |
46
|
|
|
|
|
|
|
check_request_sub => sub {}, |
47
|
|
|
|
|
|
|
check_response_sub => sub {}, |
48
|
|
|
|
|
|
|
forced_single_resultset => 1, |
49
|
|
|
|
|
|
|
max_cached_dbh_per_drh => 1, |
50
|
|
|
|
|
|
|
max_cached_sth_per_dbh => 1, |
51
|
|
|
|
|
|
|
forced_response_attributes => {}, |
52
|
|
|
|
|
|
|
forced_gofer_random => 1, |
53
|
|
|
|
|
|
|
stats => {}, |
54
|
|
|
|
|
|
|
); |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
__PACKAGE__->mk_accessors( |
57
|
|
|
|
|
|
|
keys %configuration_attributes |
58
|
|
|
|
|
|
|
); |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
sub new { |
63
|
56
|
|
|
56
|
0
|
170
|
my ($self, $args) = @_; |
64
|
56
|
|
50
|
|
|
477
|
$args->{default_connect_attributes} ||= {}; |
65
|
56
|
|
50
|
|
|
343
|
$args->{forced_connect_attributes} ||= {}; |
66
|
56
|
|
50
|
|
|
375
|
$args->{max_cached_sth_per_dbh} ||= 1000; |
67
|
56
|
|
50
|
|
|
365
|
$args->{stats} ||= {}; |
68
|
56
|
|
|
|
|
398
|
return $self->SUPER::new($args); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
sub valid_configuration_attributes { |
73
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
74
|
0
|
|
|
|
|
0
|
return { %configuration_attributes }; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my %extra_attr = ( |
79
|
|
|
|
|
|
|
# Only referenced if the driver doesn't support private_attribute_info method. |
80
|
|
|
|
|
|
|
# What driver-specific attributes should be returned for the driver being used? |
81
|
|
|
|
|
|
|
# keyed by $dbh->{Driver}{Name} |
82
|
|
|
|
|
|
|
# XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS > 0) and others |
83
|
|
|
|
|
|
|
# which would reduce processing/traffic for non-select statements |
84
|
|
|
|
|
|
|
mysql => { |
85
|
|
|
|
|
|
|
dbh => [qw( |
86
|
|
|
|
|
|
|
mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid |
87
|
|
|
|
|
|
|
mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id |
88
|
|
|
|
|
|
|
)], |
89
|
|
|
|
|
|
|
sth => [qw( |
90
|
|
|
|
|
|
|
mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment |
91
|
|
|
|
|
|
|
mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid |
92
|
|
|
|
|
|
|
)], |
93
|
|
|
|
|
|
|
# XXX this dbh_after_sth stuff is a temporary, but important, hack. |
94
|
|
|
|
|
|
|
# should be done via hash instead of arrays where the hash value contains |
95
|
|
|
|
|
|
|
# flags that can indicate which attributes need to be handled in this way |
96
|
|
|
|
|
|
|
dbh_after_sth => [qw( |
97
|
|
|
|
|
|
|
mysql_insertid |
98
|
|
|
|
|
|
|
)], |
99
|
|
|
|
|
|
|
}, |
100
|
|
|
|
|
|
|
Pg => { |
101
|
|
|
|
|
|
|
dbh => [qw( |
102
|
|
|
|
|
|
|
pg_protocol pg_lib_version pg_server_version |
103
|
|
|
|
|
|
|
pg_db pg_host pg_port pg_default_port |
104
|
|
|
|
|
|
|
pg_options pg_pid |
105
|
|
|
|
|
|
|
)], |
106
|
|
|
|
|
|
|
sth => [qw( |
107
|
|
|
|
|
|
|
pg_size pg_type pg_oid_status pg_cmd_status |
108
|
|
|
|
|
|
|
)], |
109
|
|
|
|
|
|
|
}, |
110
|
|
|
|
|
|
|
Sybase => { |
111
|
|
|
|
|
|
|
dbh => [qw( |
112
|
|
|
|
|
|
|
syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string |
113
|
|
|
|
|
|
|
)], |
114
|
|
|
|
|
|
|
sth => [qw( |
115
|
|
|
|
|
|
|
syb_types syb_proc_status syb_result_type |
116
|
|
|
|
|
|
|
)], |
117
|
|
|
|
|
|
|
}, |
118
|
|
|
|
|
|
|
SQLite => { |
119
|
|
|
|
|
|
|
dbh => [qw( |
120
|
|
|
|
|
|
|
sqlite_version |
121
|
|
|
|
|
|
|
)], |
122
|
|
|
|
|
|
|
sth => [qw( |
123
|
|
|
|
|
|
|
)], |
124
|
|
|
|
|
|
|
}, |
125
|
|
|
|
|
|
|
ExampleP => { |
126
|
|
|
|
|
|
|
dbh => [qw( |
127
|
|
|
|
|
|
|
examplep_private_dbh_attrib |
128
|
|
|
|
|
|
|
)], |
129
|
|
|
|
|
|
|
sth => [qw( |
130
|
|
|
|
|
|
|
examplep_private_sth_attrib |
131
|
|
|
|
|
|
|
)], |
132
|
|
|
|
|
|
|
dbh_after_sth => [qw( |
133
|
|
|
|
|
|
|
examplep_insertid |
134
|
|
|
|
|
|
|
)], |
135
|
|
|
|
|
|
|
}, |
136
|
|
|
|
|
|
|
); |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
sub _connect { |
140
|
6454
|
|
|
6454
|
|
11901
|
my ($self, $request) = @_; |
141
|
|
|
|
|
|
|
|
142
|
6454
|
|
|
|
|
10890
|
my $stats = $self->{stats}; |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# discard CachedKids from time to time |
145
|
6454
|
50
|
66
|
|
|
22085
|
if (++$stats->{_requests_served} % 1000 == 0 # XXX config? |
146
|
|
|
|
|
|
|
and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh} |
147
|
|
|
|
|
|
|
) { |
148
|
0
|
|
|
|
|
0
|
my %drivers = DBI->installed_drivers(); |
149
|
0
|
|
|
|
|
0
|
while ( my ($driver, $drh) = each %drivers ) { |
150
|
0
|
0
|
|
|
|
0
|
next unless my $CK = $drh->{CachedKids}; |
151
|
0
|
0
|
|
|
|
0
|
next unless keys %$CK > $max_cached_dbh_per_drh; |
152
|
0
|
0
|
|
|
|
0
|
next if $driver eq 'Gofer'; # ie transport=null when testing |
153
|
|
|
|
|
|
|
DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver", |
154
|
0
|
|
|
|
|
0
|
scalar keys %$CK, $self->{max_cached_dbh_per_drh}); |
155
|
0
|
|
0
|
|
|
0
|
$_->{Active} && $_->disconnect for values %$CK; |
156
|
0
|
|
|
|
|
0
|
%$CK = (); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# local $ENV{...} can leak, so only do it if required |
161
|
6454
|
100
|
|
|
|
33014
|
local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; |
162
|
|
|
|
|
|
|
|
163
|
6454
|
|
|
|
|
10253
|
my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; |
|
6454
|
|
|
|
|
16184
|
|
164
|
6454
|
|
50
|
|
|
14825
|
$connect_method ||= 'connect_cached'; |
165
|
6454
|
|
|
|
|
12507
|
$stats->{method_calls_dbh}->{$connect_method}++; |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# delete attributes we don't want to affect the server-side |
168
|
|
|
|
|
|
|
# (Could just do this on client-side and trust the client. DoS?) |
169
|
6454
|
|
|
|
|
10705
|
delete @{$attr}{qw(Profile InactiveDestroy AutoInactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; |
|
6454
|
|
|
|
|
19306
|
|
170
|
|
|
|
|
|
|
|
171
|
6454
|
50
|
33
|
|
|
16651
|
$dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn |
172
|
|
|
|
|
|
|
or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request"; |
173
|
|
|
|
|
|
|
|
174
|
6454
|
|
100
|
|
|
33366
|
my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
my $connect_attr = { |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
# the configured default attributes, if any |
179
|
6454
|
|
|
|
|
16276
|
%{ $self->default_connect_attributes }, |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# pass username and password as attributes |
182
|
|
|
|
|
|
|
# then they can be overridden by forced_connect_attributes |
183
|
|
|
|
|
|
|
Username => $username, |
184
|
|
|
|
|
|
|
Password => $password, |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# the requested attributes |
187
|
|
|
|
|
|
|
%$attr, |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# force some attributes the way we'd like them |
190
|
|
|
|
|
|
|
PrintWarn => $local_log, |
191
|
|
|
|
|
|
|
PrintError => $local_log, |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# the configured default attributes, if any |
194
|
6454
|
|
|
|
|
10628
|
%{ $self->forced_connect_attributes }, |
|
6454
|
|
|
|
|
17130
|
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# RaiseError must be enabled |
197
|
|
|
|
|
|
|
RaiseError => 1, |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
# reset Executed flag (of the cached handle) so we can use it to tell |
200
|
|
|
|
|
|
|
# if errors happened before the main part of the request was executed |
201
|
|
|
|
|
|
|
Executed => 0, |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# ensure this connect_cached doesn't have the same args as the client |
204
|
|
|
|
|
|
|
# because that causes subtle issues if in the same process (ie transport=null) |
205
|
|
|
|
|
|
|
# include pid to avoid problems with forking (ie null transport in mod_perl) |
206
|
|
|
|
|
|
|
# include gofer-random to avoid random behaviour leaking to other handles |
207
|
|
|
|
|
|
|
dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), |
208
|
|
|
|
|
|
|
}; |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
# XXX implement our own private connect_cached method? (with rate-limited ping) |
211
|
6454
|
|
|
|
|
33486
|
my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); |
212
|
|
|
|
|
|
|
|
213
|
6428
|
50
|
|
|
|
15840
|
$dbh->{ShowErrorStatement} = 1 if $local_log; |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# XXX should probably just be a Callbacks => arg to connect_cached |
216
|
|
|
|
|
|
|
# with a cache of pre-built callback hooks (memoized, without $self) |
217
|
6428
|
100
|
66
|
|
|
33023
|
if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) { |
218
|
2900
|
|
|
|
|
6598
|
$self->_install_rand_callbacks($dbh, $random); |
219
|
|
|
|
|
|
|
} |
220
|
|
|
|
|
|
|
|
221
|
6428
|
|
|
|
|
31184
|
my $CK = $dbh->{CachedKids}; |
222
|
6428
|
50
|
33
|
|
|
27544
|
if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) { |
223
|
0
|
|
|
|
|
0
|
%$CK = (); # clear all statement handles |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
#$dbh->trace(0); |
227
|
6428
|
|
|
|
|
10080
|
$current_dbh = $dbh; |
228
|
6428
|
|
|
|
|
33207
|
return $dbh; |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub reset_dbh { |
233
|
6428
|
|
|
6428
|
0
|
12618
|
my ($self, $dbh) = @_; |
234
|
6428
|
|
|
|
|
38075
|
$dbh->set_err(undef, undef); # clear any error state |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub new_response_with_err { |
239
|
6454
|
|
|
6454
|
0
|
16809
|
my ($self, $rv, $eval_error, $dbh) = @_; |
240
|
|
|
|
|
|
|
# this is the usual way to create a response for both success and failure |
241
|
|
|
|
|
|
|
# capture err+errstr etc and merge in $eval_error ($@) |
242
|
|
|
|
|
|
|
|
243
|
6454
|
|
|
|
|
53231
|
my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); |
244
|
|
|
|
|
|
|
|
245
|
6454
|
100
|
|
|
|
16788
|
if ($eval_error) { |
246
|
1599
|
|
50
|
|
|
2828
|
$err ||= $DBI::stderr || 1; # ensure err is true |
|
|
|
66
|
|
|
|
|
247
|
1599
|
100
|
|
|
|
2687
|
if ($errstr) { |
248
|
1597
|
50
|
|
|
|
17318
|
$eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; |
249
|
1597
|
|
|
|
|
3672
|
chomp $errstr; |
250
|
1597
|
|
|
|
|
3920
|
$errstr .= "; $eval_error"; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
else { |
253
|
2
|
|
|
|
|
3
|
$errstr = $eval_error; |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
} |
256
|
6454
|
100
|
|
|
|
13341
|
chomp $errstr if $errstr; |
257
|
|
|
|
|
|
|
|
258
|
6454
|
|
|
|
|
8423
|
my $flags; |
259
|
|
|
|
|
|
|
# (XXX if we ever add transaction support then we'll need to take extra |
260
|
|
|
|
|
|
|
# steps because the commit/rollback would reset Executed before we get here) |
261
|
6454
|
100
|
100
|
|
|
48920
|
$flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed}; |
262
|
|
|
|
|
|
|
|
263
|
6454
|
|
|
|
|
66490
|
my $response = DBI::Gofer::Response->new({ |
264
|
|
|
|
|
|
|
rv => $rv, |
265
|
|
|
|
|
|
|
err => $err, |
266
|
|
|
|
|
|
|
errstr => $errstr, |
267
|
|
|
|
|
|
|
state => $state, |
268
|
|
|
|
|
|
|
flags => $flags, |
269
|
|
|
|
|
|
|
}); |
270
|
|
|
|
|
|
|
|
271
|
6454
|
|
|
|
|
24523
|
return $response; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub execute_request { |
276
|
6454
|
|
|
6454
|
0
|
13257
|
my ($self, $request) = @_; |
277
|
|
|
|
|
|
|
# should never throw an exception |
278
|
|
|
|
|
|
|
|
279
|
6454
|
|
|
|
|
23447
|
DBI->trace_msg("-----> execute_request\n"); |
280
|
|
|
|
|
|
|
|
281
|
6454
|
|
|
|
|
9575
|
my @warnings; |
282
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
283
|
22
|
|
|
22
|
|
276
|
push @warnings, @_; |
284
|
22
|
50
|
|
|
|
118
|
warn @_ if $local_log; |
285
|
6454
|
|
|
|
|
44603
|
}; |
286
|
|
|
|
|
|
|
|
287
|
6454
|
|
|
|
|
12662
|
my $response = eval { |
288
|
|
|
|
|
|
|
|
289
|
6454
|
50
|
|
|
|
16622
|
if (my $check_request_sub = $self->check_request_sub) { |
290
|
0
|
0
|
|
|
|
0
|
$request = $check_request_sub->($request, $self) |
291
|
|
|
|
|
|
|
or die "check_request_sub failed"; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
6454
|
|
50
|
|
|
18546
|
my $version = $request->version || 0; |
295
|
6454
|
50
|
33
|
|
|
42330
|
die ref($request)." version $version is not supported" |
296
|
|
|
|
|
|
|
if $version < 0.009116 or $version >= 1; |
297
|
|
|
|
|
|
|
|
298
|
6454
|
100
|
|
|
|
18167
|
($request->is_sth_request) |
299
|
|
|
|
|
|
|
? $self->execute_sth_request($request) |
300
|
|
|
|
|
|
|
: $self->execute_dbh_request($request); |
301
|
|
|
|
|
|
|
}; |
302
|
6454
|
|
33
|
|
|
27345
|
$response ||= $self->new_response_with_err(undef, $@, $current_dbh); |
303
|
|
|
|
|
|
|
|
304
|
6454
|
50
|
|
|
|
19209
|
if (my $check_response_sub = $self->check_response_sub) { |
305
|
|
|
|
|
|
|
# not protected with an eval so it can choose to throw an exception |
306
|
0
|
|
|
|
|
0
|
my $new = $check_response_sub->($response, $self, $request); |
307
|
0
|
0
|
|
|
|
0
|
$response = $new if ref $new; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
6454
|
|
|
|
|
47744
|
undef $current_dbh; |
311
|
|
|
|
|
|
|
|
312
|
6454
|
100
|
|
|
|
53364
|
$response->warnings(\@warnings) if @warnings; |
313
|
6454
|
|
|
|
|
21778
|
DBI->trace_msg("<----- execute_request\n"); |
314
|
6454
|
|
|
|
|
49104
|
return $response; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub execute_dbh_request { |
319
|
3685
|
|
|
3685
|
0
|
6477
|
my ($self, $request) = @_; |
320
|
3685
|
|
|
|
|
5525
|
my $stats = $self->{stats}; |
321
|
|
|
|
|
|
|
|
322
|
3685
|
|
|
|
|
4305
|
my $dbh; |
323
|
3685
|
|
100
|
|
|
4871
|
my $rv_ref = eval { |
324
|
|
|
|
|
|
|
$dbh = $self->_connect($request); |
325
|
|
|
|
|
|
|
my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] |
326
|
|
|
|
|
|
|
my $wantarray = shift @$args; |
327
|
|
|
|
|
|
|
my $meth = shift @$args; |
328
|
|
|
|
|
|
|
$stats->{method_calls_dbh}->{$meth}++; |
329
|
|
|
|
|
|
|
my @rv = ($wantarray) |
330
|
|
|
|
|
|
|
? $dbh->$meth(@$args) |
331
|
|
|
|
|
|
|
: scalar $dbh->$meth(@$args); |
332
|
|
|
|
|
|
|
\@rv; |
333
|
|
|
|
|
|
|
} || []; |
334
|
3685
|
|
|
|
|
13908
|
my $response = $self->new_response_with_err($rv_ref, $@, $dbh); |
335
|
|
|
|
|
|
|
|
336
|
3685
|
100
|
|
|
|
7613
|
return $response if not $dbh; |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
# does this request also want any dbh attributes returned? |
339
|
3659
|
100
|
|
|
|
9161
|
if (my $dbh_attributes = $request->dbh_attributes) { |
340
|
715
|
|
|
|
|
3145
|
$response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) ); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
3659
|
50
|
33
|
|
|
11983
|
if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) { |
344
|
0
|
|
|
|
|
0
|
$stats->{method_calls_dbh}->{last_insert_id}++; |
345
|
0
|
|
|
|
|
0
|
my $id = $dbh->last_insert_id( @$lid_args ); |
346
|
0
|
|
|
|
|
0
|
$response->last_insert_id( $id ); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
3659
|
100
|
66
|
|
|
17136
|
if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) { |
350
|
|
|
|
|
|
|
# dbh_method_call was probably a metadata method like table_info |
351
|
|
|
|
|
|
|
# that returns a statement handle, so turn the $sth into resultset |
352
|
10
|
|
|
|
|
33
|
my $sth = $rv_ref->[0]; |
353
|
10
|
|
|
|
|
61
|
$response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); |
354
|
10
|
|
|
|
|
47
|
$response->rv("(sth)"); # don't try to return actual sth |
355
|
|
|
|
|
|
|
} |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
# we're finished with this dbh for this request |
358
|
3659
|
|
|
|
|
10252
|
$self->reset_dbh($dbh); |
359
|
|
|
|
|
|
|
|
360
|
3659
|
|
|
|
|
17285
|
return $response; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
sub gather_dbh_attributes { |
365
|
3428
|
|
|
3428
|
0
|
8744
|
my ($self, $dbh, $dbh_attributes) = @_; |
366
|
3428
|
|
|
|
|
10964
|
my @req_attr_names = @$dbh_attributes; |
367
|
3428
|
50
|
|
|
|
11046
|
if ($req_attr_names[0] eq '*') { # auto include std + private |
368
|
3428
|
|
|
|
|
5362
|
shift @req_attr_names; |
369
|
3428
|
|
|
|
|
6385
|
push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) }; |
|
3428
|
|
|
|
|
9734
|
|
370
|
|
|
|
|
|
|
} |
371
|
3428
|
|
|
|
|
6650
|
my %dbh_attr_values; |
372
|
3428
|
|
|
|
|
18061
|
@dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names); |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# XXX piggyback installed_methods onto dbh_attributes for now |
375
|
3428
|
|
|
|
|
32106
|
$dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods }; |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
# XXX piggyback default_methods onto dbh_attributes for now |
378
|
3428
|
|
|
|
|
12818
|
$dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh); |
379
|
|
|
|
|
|
|
|
380
|
3428
|
|
|
|
|
12972
|
return \%dbh_attr_values; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub _std_response_attribute_names { |
385
|
6151
|
|
|
6151
|
|
11762
|
my ($self, $h) = @_; |
386
|
6151
|
|
33
|
|
|
17151
|
$h = tied(%$h) || $h; # switch to inner handle |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# cache the private_attribute_info data for each handle |
389
|
|
|
|
|
|
|
# XXX might be better to cache it in the executor |
390
|
|
|
|
|
|
|
# as it's unlikely to change |
391
|
|
|
|
|
|
|
# or perhaps at least cache it in the dbh even for sth |
392
|
|
|
|
|
|
|
# as the sth are typically very short lived |
393
|
|
|
|
|
|
|
|
394
|
6151
|
|
|
|
|
10796
|
my ($dbh, $h_type, $driver_name, @attr_names); |
395
|
|
|
|
|
|
|
|
396
|
6151
|
100
|
|
|
|
16013
|
if ($dbh = $h->{Database}) { # is an sth |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# does the dbh already have the answer cached? |
399
|
2723
|
100
|
|
|
|
7748
|
return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth}; |
400
|
|
|
|
|
|
|
|
401
|
2661
|
|
|
|
|
8529
|
($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name}); |
402
|
2661
|
|
|
|
|
11592
|
push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE); |
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
else { # is a dbh |
405
|
3428
|
100
|
|
|
|
8820
|
return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh}; |
406
|
|
|
|
|
|
|
|
407
|
3324
|
|
|
|
|
10230
|
($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h); |
408
|
|
|
|
|
|
|
# explicitly add these because drivers may have different defaults |
409
|
|
|
|
|
|
|
# add Name so the client gets the real Name of the connection |
410
|
3324
|
|
|
|
|
12289
|
push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
5985
|
100
|
|
|
|
34654
|
if (my $pai = $h->private_attribute_info) { |
414
|
2317
|
|
|
|
|
10840
|
push @attr_names, keys %$pai; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
else { |
417
|
3668
|
100
|
|
|
|
16911
|
push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []}; |
|
3668
|
|
|
|
|
16032
|
|
418
|
|
|
|
|
|
|
} |
419
|
5985
|
50
|
|
|
|
17631
|
if (my $fra = $self->{forced_response_attributes}) { |
420
|
0
|
0
|
|
|
|
0
|
push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []} |
|
0
|
|
|
|
|
0
|
|
421
|
|
|
|
|
|
|
} |
422
|
5985
|
|
|
|
|
47247
|
$dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n"); |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# cache into the dbh even for sth, as the dbh is usually longer lived |
425
|
5985
|
|
|
|
|
44819
|
return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names; |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
sub execute_sth_request { |
430
|
2769
|
|
|
2769
|
0
|
6737
|
my ($self, $request) = @_; |
431
|
2769
|
|
|
|
|
7324
|
my $dbh; |
432
|
|
|
|
|
|
|
my $sth; |
433
|
2769
|
|
|
|
|
0
|
my $last_insert_id; |
434
|
2769
|
|
|
|
|
5461
|
my $stats = $self->{stats}; |
435
|
|
|
|
|
|
|
|
436
|
2769
|
|
|
|
|
4539
|
my $rv = eval { |
437
|
2769
|
|
|
|
|
7648
|
$dbh = $self->_connect($request); |
438
|
|
|
|
|
|
|
|
439
|
2769
|
|
|
|
|
10579
|
my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] |
440
|
2769
|
|
|
|
|
5754
|
shift @$args; # discard wantarray |
441
|
2769
|
|
|
|
|
6515
|
my $meth = shift @$args; |
442
|
2769
|
|
|
|
|
7037
|
$stats->{method_calls_sth}->{$meth}++; |
443
|
2769
|
|
|
|
|
17353
|
$sth = $dbh->$meth(@$args); |
444
|
2713
|
|
|
|
|
13708
|
my $last = '(sth)'; # a true value (don't try to return actual sth) |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
# execute methods on the sth, e.g., bind_param & execute |
447
|
2713
|
100
|
|
|
|
9811
|
if (my $calls = $request->sth_method_calls) { |
448
|
2271
|
|
|
|
|
6604
|
for my $meth_call (@$calls) { |
449
|
7493
|
|
|
|
|
15230
|
my $method = shift @$meth_call; |
450
|
7493
|
|
|
|
|
13407
|
$stats->{method_calls_sth}->{$method}++; |
451
|
7493
|
|
|
|
|
29456
|
$last = $sth->$method(@$meth_call); |
452
|
|
|
|
|
|
|
} |
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
|
455
|
2689
|
50
|
|
|
|
15566
|
if (my $lid_args = $request->dbh_last_insert_id_args) { |
456
|
0
|
|
|
|
|
0
|
$stats->{method_calls_sth}->{last_insert_id}++; |
457
|
0
|
|
|
|
|
0
|
$last_insert_id = $dbh->last_insert_id( @$lid_args ); |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
2689
|
|
|
|
|
7216
|
$last; |
461
|
|
|
|
|
|
|
}; |
462
|
2769
|
|
|
|
|
12253
|
my $response = $self->new_response_with_err($rv, $@, $dbh); |
463
|
|
|
|
|
|
|
|
464
|
2769
|
50
|
|
|
|
7783
|
return $response if not $dbh; |
465
|
|
|
|
|
|
|
|
466
|
2769
|
50
|
|
|
|
6993
|
$response->last_insert_id( $last_insert_id ) |
467
|
|
|
|
|
|
|
if defined $last_insert_id; |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
# even if the eval failed we still want to try to gather attribute values |
470
|
|
|
|
|
|
|
# (XXX would be nice to be able to support streaming of results. |
471
|
|
|
|
|
|
|
# which would reduce memory usage and latency for large results) |
472
|
2769
|
100
|
|
|
|
6642
|
if ($sth) { |
473
|
2713
|
|
|
|
|
9043
|
$response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); |
474
|
2713
|
|
|
|
|
10839
|
$sth->finish; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# does this request also want any dbh attributes returned? |
478
|
2769
|
|
|
|
|
8197
|
my $dbh_attr_set; |
479
|
2769
|
100
|
|
|
|
7903
|
if (my $dbh_attributes = $request->dbh_attributes) { |
480
|
2713
|
|
|
|
|
9005
|
$dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
# XXX needs to be integrated with private_attribute_info() etc |
483
|
2769
|
100
|
|
|
|
22935
|
if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { |
484
|
2113
|
|
|
|
|
11042
|
@{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); |
|
2113
|
|
|
|
|
7208
|
|
485
|
|
|
|
|
|
|
} |
486
|
2769
|
100
|
66
|
|
|
28828
|
$response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; |
487
|
|
|
|
|
|
|
|
488
|
2769
|
|
|
|
|
9295
|
$self->reset_dbh($dbh); |
489
|
|
|
|
|
|
|
|
490
|
2769
|
|
|
|
|
48754
|
return $response; |
491
|
|
|
|
|
|
|
} |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
sub gather_sth_resultsets { |
495
|
2723
|
|
|
2723
|
0
|
7045
|
my ($self, $sth, $request, $response) = @_; |
496
|
2723
|
|
|
|
|
4930
|
my $resultsets = eval { |
497
|
|
|
|
|
|
|
|
498
|
2723
|
|
|
|
|
7685
|
my $attr_names = $self->_std_response_attribute_names($sth); |
499
|
2723
|
|
|
|
|
6228
|
my $sth_attr = {}; |
500
|
2723
|
|
|
|
|
21228
|
$sth_attr->{$_} = 1 for @$attr_names; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# let the client add/remove sth attributes |
503
|
2723
|
100
|
|
|
|
10000
|
if (my $sth_result_attr = $request->sth_result_attr) { |
504
|
|
|
|
|
|
|
$sth_attr->{$_} = $sth_result_attr->{$_} |
505
|
2713
|
|
|
|
|
8398
|
for keys %$sth_result_attr; |
506
|
|
|
|
|
|
|
} |
507
|
2723
|
|
|
|
|
11712
|
my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; |
|
21158
|
|
|
|
|
37056
|
|
508
|
|
|
|
|
|
|
|
509
|
2723
|
|
|
|
|
6856
|
my $row_count = 0; |
510
|
2723
|
|
|
|
|
5605
|
my $rs_list = []; |
511
|
2723
|
|
|
|
|
4427
|
while (1) { |
512
|
2723
|
|
|
|
|
8362
|
my $rs = $self->fetch_result_set($sth, \@sth_attr); |
513
|
2723
|
|
|
|
|
8642
|
push @$rs_list, $rs; |
514
|
2723
|
100
|
|
|
|
8318
|
if (my $rows = $rs->{rowset}) { |
515
|
2080
|
|
|
|
|
4640
|
$row_count += @$rows; |
516
|
|
|
|
|
|
|
} |
517
|
2723
|
50
|
|
|
|
7093
|
last if $self->{forced_single_resultset}; |
518
|
2723
|
50
|
33
|
|
|
16131
|
last if !($sth->more_results || $sth->{syb_more_results}); |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
2723
|
|
|
|
|
13019
|
my $stats = $self->{stats}; |
522
|
2723
|
|
|
|
|
5337
|
$stats->{rows_returned_total} += $row_count; |
523
|
|
|
|
|
|
|
$stats->{rows_returned_max} = $row_count |
524
|
2723
|
100
|
100
|
|
|
10253
|
if $row_count > ($stats->{rows_returned_max}||0); |
525
|
|
|
|
|
|
|
|
526
|
2723
|
|
|
|
|
14054
|
$rs_list; |
527
|
|
|
|
|
|
|
}; |
528
|
2723
|
50
|
|
|
|
7367
|
$response->add_err(1, $@) if $@; |
529
|
2723
|
|
|
|
|
13105
|
return $resultsets; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
sub fetch_result_set { |
534
|
2723
|
|
|
2723
|
0
|
6588
|
my ($self, $sth, $sth_attr) = @_; |
535
|
2723
|
|
|
|
|
4704
|
my %meta; |
536
|
2723
|
|
|
|
|
4437
|
eval { |
537
|
2723
|
|
|
|
|
15459
|
@meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); |
538
|
|
|
|
|
|
|
# we assume @$sth_attr contains NUM_OF_FIELDS |
539
|
|
|
|
|
|
|
$meta{rowset} = $sth->fetchall_arrayref() |
540
|
2723
|
100
|
100
|
|
|
26786
|
if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT |
541
|
|
|
|
|
|
|
# the fetchall_arrayref may fail with a 'not executed' kind of error |
542
|
|
|
|
|
|
|
# because gather_sth_resultsets/fetch_result_set are called even if |
543
|
|
|
|
|
|
|
# execute() failed, or even if there was no execute() call at all. |
544
|
|
|
|
|
|
|
# The corresponding error goes into the resultset err, not the top-level |
545
|
|
|
|
|
|
|
# response err, so in most cases this resultset err is never noticed. |
546
|
|
|
|
|
|
|
}; |
547
|
2723
|
100
|
|
|
|
13414
|
if ($@) { |
548
|
244
|
|
|
|
|
814
|
chomp $@; |
549
|
244
|
|
100
|
|
|
1458
|
$meta{err} = $DBI::err || 1; |
550
|
244
|
|
66
|
|
|
1688
|
$meta{errstr} = $DBI::errstr || $@; |
551
|
244
|
|
|
|
|
903
|
$meta{state} = $DBI::state; |
552
|
|
|
|
|
|
|
} |
553
|
2723
|
|
|
|
|
7402
|
return \%meta; |
554
|
|
|
|
|
|
|
} |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
|
557
|
|
|
|
|
|
|
sub _get_default_methods { |
558
|
3428
|
|
|
3428
|
|
7930
|
my ($dbh) = @_; |
559
|
|
|
|
|
|
|
# returns a ref to a hash of dbh method names for methods which the driver |
560
|
|
|
|
|
|
|
# hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. |
561
|
3428
|
50
|
|
|
|
26090
|
my $ImplementorClass = $dbh->{ImplementorClass} or die; |
562
|
3428
|
|
|
|
|
17550
|
my %default_methods; |
563
|
3428
|
|
|
|
|
10643
|
for my $method (@all_dbh_methods) { |
564
|
202252
|
|
100
|
|
|
433264
|
my $dbi_sub = $all_dbh_methods{$method} || 42; |
565
|
202252
|
|
100
|
|
|
633245
|
my $imp_sub = $ImplementorClass->can($method) || 42; |
566
|
202252
|
100
|
|
|
|
390318
|
next if $imp_sub != $dbi_sub; |
567
|
|
|
|
|
|
|
#warn("default $method\n"); |
568
|
156368
|
|
|
|
|
306951
|
$default_methods{$method} = 1; |
569
|
|
|
|
|
|
|
} |
570
|
3428
|
|
|
|
|
14343
|
return \%default_methods; |
571
|
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
|
574
|
|
|
|
|
|
|
# XXX would be nice to make this a generic DBI module |
575
|
|
|
|
|
|
|
sub _install_rand_callbacks { |
576
|
2900
|
|
|
2900
|
|
4860
|
my ($self, $dbh, $dbi_gofer_random) = @_; |
577
|
|
|
|
|
|
|
|
578
|
2900
|
|
100
|
|
|
15936
|
my $callbacks = $dbh->{Callbacks} || {}; |
579
|
2900
|
|
100
|
|
|
13491
|
my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; |
580
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
# return if we've already setup this handle with callbacks for these specs |
582
|
2900
|
100
|
100
|
|
|
10300
|
return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); |
583
|
|
|
|
|
|
|
#warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; |
584
|
7
|
|
|
|
|
15
|
$callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; |
585
|
|
|
|
|
|
|
|
586
|
7
|
|
|
|
|
15
|
my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); |
587
|
7
|
|
|
|
|
40
|
my @specs = split /,/, $dbi_gofer_random; |
588
|
7
|
|
|
|
|
18
|
for my $spec (@specs) { |
589
|
14
|
100
|
|
|
|
54
|
if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { |
590
|
6
|
|
|
|
|
19
|
$fail_percent = $1; |
591
|
6
|
|
|
|
|
15
|
$spec_part{fail} = $spec; |
592
|
6
|
|
|
|
|
10
|
next; |
593
|
|
|
|
|
|
|
} |
594
|
8
|
50
|
|
|
|
22
|
if ($spec =~ m/^err=(-?\d+)$/) { |
595
|
0
|
|
|
|
|
0
|
$fail_err = $1; |
596
|
0
|
|
|
|
|
0
|
$spec_part{err} = $spec; |
597
|
0
|
|
|
|
|
0
|
next; |
598
|
|
|
|
|
|
|
} |
599
|
8
|
100
|
|
|
|
53
|
if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { |
|
|
50
|
|
|
|
|
|
600
|
1
|
|
|
|
|
5
|
$delay_duration = $1; |
601
|
1
|
|
|
|
|
3
|
$delay_percent = $2; |
602
|
1
|
|
|
|
|
3
|
$spec_part{delay} = $spec; |
603
|
1
|
|
|
|
|
3
|
next; |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
elsif ($spec !~ m/^(\w+|\*)$/) { |
606
|
0
|
|
|
|
|
0
|
warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; |
607
|
0
|
|
|
|
|
0
|
next; |
608
|
|
|
|
|
|
|
} |
609
|
|
|
|
|
|
|
|
610
|
7
|
|
|
|
|
13
|
my $method = $spec; |
611
|
7
|
0
|
33
|
|
|
18
|
if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { |
|
|
|
0
|
|
|
|
|
612
|
0
|
|
|
|
|
0
|
warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; |
613
|
0
|
|
|
|
|
0
|
next; |
614
|
|
|
|
|
|
|
} |
615
|
7
|
50
|
66
|
|
|
25
|
unless (defined $fail_percent or defined $delay_percent) { |
616
|
0
|
|
|
|
|
0
|
warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceded by 'fail=N' and/or 'delayN=N'"; |
617
|
0
|
|
|
|
|
0
|
next; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
7
|
|
|
|
|
29
|
push @spec_note, join(",", values(%spec_part), $method); |
621
|
7
|
|
|
|
|
37
|
$callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); |
622
|
|
|
|
|
|
|
} |
623
|
7
|
50
|
|
|
|
108
|
warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" |
624
|
|
|
|
|
|
|
if @spec_note; |
625
|
7
|
|
|
|
|
41
|
$dbh->{Callbacks} = $callbacks; |
626
|
7
|
|
|
|
|
33
|
$dbh->{private_gofer_rand_fail_callbacks} = $callbacks; |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
my %_mk_rand_callback_seqn; |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
sub _mk_rand_callback { |
632
|
7
|
|
|
7
|
|
25
|
my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; |
633
|
7
|
|
|
|
|
23
|
my ($fail_modrate, $delay_modrate); |
634
|
7
|
100
|
100
|
|
|
20
|
$fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; |
|
7
|
|
|
|
|
35
|
|
635
|
7
|
100
|
100
|
|
|
38
|
$delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; |
|
7
|
|
|
|
|
17
|
|
636
|
|
|
|
|
|
|
# note that $method may be "*" but that's not recommended or documented or wise |
637
|
|
|
|
|
|
|
return sub { |
638
|
2900
|
|
|
2900
|
|
5026
|
my ($h) = @_; |
639
|
2900
|
|
|
|
|
4371
|
my $seqn = ++$_mk_rand_callback_seqn{$method}; |
640
|
2900
|
50
|
|
|
|
6605
|
my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : |
|
|
100
|
|
|
|
|
|
641
|
|
|
|
|
|
|
($delay_percent < 0) ? !($seqn % $delay_modrate): 0; |
642
|
2900
|
100
|
|
|
|
7614
|
my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : |
|
|
100
|
|
|
|
|
|
643
|
|
|
|
|
|
|
($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; |
644
|
|
|
|
|
|
|
#no warnings 'uninitialized'; |
645
|
|
|
|
|
|
|
#warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; |
646
|
2900
|
100
|
|
|
|
4974
|
if ($delay) { |
647
|
11
|
|
|
|
|
54
|
my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; |
648
|
|
|
|
|
|
|
# Note what's happening in a trace message. If the delay percent is an even |
649
|
|
|
|
|
|
|
# number then use warn() instead so it's sent back to the client. |
650
|
11
|
50
|
|
|
|
148
|
($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); |
651
|
11
|
|
|
|
|
1102014
|
select undef, undef, undef, $delay_duration; # allows floating point value |
652
|
|
|
|
|
|
|
} |
653
|
2900
|
100
|
|
|
|
4469
|
if ($fail) { |
654
|
1487
|
|
|
|
|
2040
|
undef $_; # tell DBI to not call the method |
655
|
|
|
|
|
|
|
# the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr |
656
|
|
|
|
|
|
|
# as it's checked for in a few places, such as the gofer retry logic |
657
|
1487
|
|
33
|
|
|
28393
|
return $h->set_err($fail_err || $DBI::stderr, |
658
|
|
|
|
|
|
|
"fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); |
659
|
|
|
|
|
|
|
} |
660
|
1413
|
|
|
|
|
4668
|
return; |
661
|
|
|
|
|
|
|
} |
662
|
7
|
|
|
|
|
122
|
} |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
sub update_stats { |
666
|
0
|
|
|
0
|
0
|
|
my ($self, |
667
|
|
|
|
|
|
|
$request, $response, |
668
|
|
|
|
|
|
|
$frozen_request, $frozen_response, |
669
|
|
|
|
|
|
|
$time_received, |
670
|
|
|
|
|
|
|
$store_meta, $other_meta, |
671
|
|
|
|
|
|
|
) = @_; |
672
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
# should always have a response object here |
674
|
0
|
0
|
|
|
|
|
carp("No response object provided") unless $request; |
675
|
|
|
|
|
|
|
|
676
|
0
|
|
|
|
|
|
my $stats = $self->{stats}; |
677
|
|
|
|
|
|
|
$stats->{frozen_request_max_bytes} = length($frozen_request) |
678
|
|
|
|
|
|
|
if $frozen_request |
679
|
0
|
0
|
0
|
|
|
|
&& length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); |
|
|
|
0
|
|
|
|
|
680
|
|
|
|
|
|
|
$stats->{frozen_response_max_bytes} = length($frozen_response) |
681
|
|
|
|
|
|
|
if $frozen_response |
682
|
0
|
0
|
0
|
|
|
|
&& length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); |
|
|
|
0
|
|
|
|
|
683
|
|
|
|
|
|
|
|
684
|
0
|
|
|
|
|
|
my $recent; |
685
|
0
|
0
|
|
|
|
|
if (my $track_recent = $self->{track_recent}) { |
686
|
0
|
0
|
|
|
|
|
$recent = { |
687
|
|
|
|
|
|
|
request => $frozen_request, |
688
|
|
|
|
|
|
|
response => $frozen_response, |
689
|
|
|
|
|
|
|
time_received => $time_received, |
690
|
|
|
|
|
|
|
duration => dbi_time()-$time_received, |
691
|
|
|
|
|
|
|
# for any other info |
692
|
|
|
|
|
|
|
($store_meta) ? (meta => $store_meta) : (), |
693
|
|
|
|
|
|
|
}; |
694
|
0
|
0
|
0
|
|
|
|
$recent->{request_object} = $request |
695
|
|
|
|
|
|
|
if !$frozen_request && $request; |
696
|
0
|
0
|
|
|
|
|
$recent->{response_object} = $response |
697
|
|
|
|
|
|
|
if !$frozen_response; |
698
|
0
|
|
0
|
|
|
|
my @queues = ($stats->{recent_requests} ||= []); |
699
|
0
|
0
|
0
|
|
|
|
push @queues, ($stats->{recent_errors} ||= []) |
|
|
|
0
|
|
|
|
|
700
|
|
|
|
|
|
|
if !$response or $response->err; |
701
|
0
|
|
|
|
|
|
for my $queue (@queues) { |
702
|
0
|
|
|
|
|
|
push @$queue, $recent; |
703
|
0
|
0
|
|
|
|
|
shift @$queue if @$queue > $track_recent; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
} |
706
|
0
|
|
|
|
|
|
return $recent; |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
1; |
711
|
|
|
|
|
|
|
__END__ |