File Coverage

blib/lib/DBI/Gofer/Execute.pm
Criterion Covered Total %
statement 249 295 84.4
branch 99 156 63.4
condition 57 115 49.5
subroutine 23 25 92.0
pod 0 11 0.0
total 428 602 71.1


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__