[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package DBI::Gofer::Execute; 2 3 # $Id: Execute.pm 11544 2008-07-20 06:43:16Z timbo $ 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 use strict; 11 use warnings; 12 13 use Carp; 14 15 use DBI qw(dbi_time); 16 use DBI::Gofer::Request; 17 use DBI::Gofer::Response; 18 19 use base qw(DBI::Util::_accessor); 20 21 our $VERSION = sprintf("0.%06d", q$Revision: 11544 $ =~ /(\d+)/o); 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 my ($self, $args) = @_; 64 $args->{default_connect_attributes} ||= {}; 65 $args->{forced_connect_attributes} ||= {}; 66 $args->{max_cached_sth_per_dbh} ||= 1000; 67 $args->{stats} ||= {}; 68 return $self->SUPER::new($args); 69 } 70 71 72 sub valid_configuration_attributes { 73 my $self = shift; 74 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 my ($self, $request) = @_; 141 142 my $stats = $self->{stats}; 143 144 # discard CachedKids from time to time 145 if (++$stats->{_requests_served} % 1000 == 0 # XXX config? 146 and my $max_cached_dbh_per_drh = $self->{max_cached_dbh_per_drh} 147 ) { 148 my %drivers = DBI->installed_drivers(); 149 while ( my ($driver, $drh) = each %drivers ) { 150 next unless my $CK = $drh->{CachedKids}; 151 next unless keys %$CK > $max_cached_dbh_per_drh; 152 next if $driver eq 'Gofer'; # ie transport=null when testing 153 DBI->trace_msg(sprintf "Clearing %d cached dbh from $driver", 154 scalar keys %$CK, $self->{max_cached_dbh_per_drh}); 155 $_->{Active} && $_->disconnect for values %$CK; 156 %$CK = (); 157 } 158 } 159 160 local $ENV{DBI_AUTOPROXY}; # limit the insanity 161 162 my ($connect_method, $dsn, $username, $password, $attr) = @{ $request->dbh_connect_call }; 163 $connect_method ||= 'connect_cached'; 164 $stats->{method_calls_dbh}->{$connect_method}++; 165 166 # delete attributes we don't want to affect the server-side 167 # (Could just do this on client-side and trust the client. DoS?) 168 delete @{$attr}{qw(Profile InactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)}; 169 170 $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn 171 or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request"; 172 173 my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || ''; 174 175 my $connect_attr = { 176 177 # the configured default attributes, if any 178 %{ $self->default_connect_attributes }, 179 180 # pass username and password as attributes 181 # then they can be overridden by forced_connect_attributes 182 Username => $username, 183 Password => $password, 184 185 # the requested attributes 186 %$attr, 187 188 # force some attributes the way we'd like them 189 PrintWarn => $local_log, 190 PrintError => $local_log, 191 192 # the configured default attributes, if any 193 %{ $self->forced_connect_attributes }, 194 195 # RaiseError must be enabled 196 RaiseError => 1, 197 198 # reset Executed flag (of the cached handle) so we can use it to tell 199 # if errors happened before the main part of the request was executed 200 Executed => 0, 201 202 # ensure this connect_cached doesn't have the same args as the client 203 # because that causes subtle issues if in the same process (ie transport=null) 204 # include pid to avoid problems with forking (ie null transport in mod_perl) 205 # include gofer-random to avoid random behaviour leaking to other handles 206 dbi_go_execute_unique => join("|", __PACKAGE__, $$, $random), 207 }; 208 209 # XXX implement our own private connect_cached method? (with rate-limited ping) 210 my $dbh = DBI->$connect_method($dsn, undef, undef, $connect_attr); 211 212 $dbh->{ShowErrorStatement} = 1 if $local_log; 213 214 # XXX should probably just be a Callbacks => arg to connect_cached 215 # with a cache of pre-built callback hooks (memoized, without $self) 216 if (my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) { 217 $self->_install_rand_callbacks($dbh, $random); 218 } 219 220 my $CK = $dbh->{CachedKids}; 221 if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) { 222 %$CK = (); # clear all statement handles 223 } 224 225 #$dbh->trace(0); 226 $current_dbh = $dbh; 227 return $dbh; 228 } 229 230 231 sub reset_dbh { 232 my ($self, $dbh) = @_; 233 $dbh->set_err(undef, undef); # clear any error state 234 } 235 236 237 sub new_response_with_err { 238 my ($self, $rv, $eval_error, $dbh) = @_; 239 # this is the usual way to create a response for both success and failure 240 # capture err+errstr etc and merge in $eval_error ($@) 241 242 my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state); 243 244 if ($eval_error) { 245 $err ||= $DBI::stderr || 1; # ensure err is true 246 if ($errstr) { 247 $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr; 248 chomp $errstr; 249 $errstr .= "; $eval_error"; 250 } 251 else { 252 $errstr = $eval_error; 253 } 254 } 255 chomp $errstr if $errstr; 256 257 my $flags; 258 # (XXX if we ever add transaction support then we'll need to take extra 259 # steps because the commit/rollback would reset Executed before we get here) 260 $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed}; 261 262 my $response = DBI::Gofer::Response->new({ 263 rv => $rv, 264 err => $err, 265 errstr => $errstr, 266 state => $state, 267 flags => $flags, 268 }); 269 270 return $response; 271 } 272 273 274 sub execute_request { 275 my ($self, $request) = @_; 276 # should never throw an exception 277 278 DBI->trace_msg("-----> execute_request\n"); 279 280 my @warnings; 281 local $SIG{__WARN__} = sub { 282 push @warnings, @_; 283 warn @_ if $local_log; 284 }; 285 286 my $response = eval { 287 288 if (my $check_request_sub = $self->check_request_sub) { 289 $request = $check_request_sub->($request, $self) 290 or die "check_request_sub failed"; 291 } 292 293 my $version = $request->version || 0; 294 die ref($request)." version $version is not supported" 295 if $version < 0.009116 or $version >= 1; 296 297 ($request->is_sth_request) 298 ? $self->execute_sth_request($request) 299 : $self->execute_dbh_request($request); 300 }; 301 $response ||= $self->new_response_with_err(undef, $@, $current_dbh); 302 303 if (my $check_response_sub = $self->check_response_sub) { 304 # not protected with an eval so it can choose to throw an exception 305 my $new = $check_response_sub->($response, $self, $request); 306 $response = $new if ref $new; 307 } 308 309 undef $current_dbh; 310 311 $response->warnings(\@warnings) if @warnings; 312 DBI->trace_msg("<----- execute_request\n"); 313 return $response; 314 } 315 316 317 sub execute_dbh_request { 318 my ($self, $request) = @_; 319 my $stats = $self->{stats}; 320 321 my $dbh; 322 my $rv_ref = eval { 323 $dbh = $self->_connect($request); 324 my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] 325 my $wantarray = shift @$args; 326 my $meth = shift @$args; 327 $stats->{method_calls_dbh}->{$meth}++; 328 my @rv = ($wantarray) 329 ? $dbh->$meth(@$args) 330 : scalar $dbh->$meth(@$args); 331 \@rv; 332 } || []; 333 my $response = $self->new_response_with_err($rv_ref, $@, $dbh); 334 335 return $response if not $dbh; 336 337 # does this request also want any dbh attributes returned? 338 if (my $dbh_attributes = $request->dbh_attributes) { 339 $response->dbh_attributes( $self->gather_dbh_attributes($dbh, $dbh_attributes) ); 340 } 341 342 if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) { 343 $stats->{method_calls_dbh}->{last_insert_id}++; 344 my $id = $dbh->last_insert_id( @$lid_args ); 345 $response->last_insert_id( $id ); 346 } 347 348 if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) { 349 # dbh_method_call was probably a metadata method like table_info 350 # that returns a statement handle, so turn the $sth into resultset 351 my $sth = $rv_ref->[0]; 352 $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); 353 $response->rv("(sth)"); # don't try to return actual sth 354 } 355 356 # we're finished with this dbh for this request 357 $self->reset_dbh($dbh); 358 359 return $response; 360 } 361 362 363 sub gather_dbh_attributes { 364 my ($self, $dbh, $dbh_attributes) = @_; 365 my @req_attr_names = @$dbh_attributes; 366 if ($req_attr_names[0] eq '*') { # auto include std + private 367 shift @req_attr_names; 368 push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) }; 369 } 370 my %dbh_attr_values; 371 @dbh_attr_values{@req_attr_names} = $dbh->FETCH_many(@req_attr_names); 372 373 # XXX piggyback installed_methods onto dbh_attributes for now 374 $dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods }; 375 376 # XXX piggyback default_methods onto dbh_attributes for now 377 $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh); 378 379 return \%dbh_attr_values; 380 } 381 382 383 sub _std_response_attribute_names { 384 my ($self, $h) = @_; 385 $h = tied(%$h) || $h; # switch to inner handle 386 387 # cache the private_attribute_info data for each handle 388 # XXX might be better to cache it in the executor 389 # as it's unlikely to change 390 # or perhaps at least cache it in the dbh even for sth 391 # as the sth are typically very short lived 392 393 my ($dbh, $h_type, $driver_name, @attr_names); 394 395 if ($dbh = $h->{Database}) { # is an sth 396 397 # does the dbh already have the answer cached? 398 return $dbh->{private_gofer_std_attr_names_sth} if $dbh->{private_gofer_std_attr_names_sth}; 399 400 ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name}); 401 push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE); 402 } 403 else { # is a dbh 404 return $h->{private_gofer_std_attr_names_dbh} if $h->{private_gofer_std_attr_names_dbh}; 405 406 ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h); 407 # explicitly add these because drivers may have different defaults 408 # add Name so the client gets the real Name of the connection 409 push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name); 410 } 411 412 if (my $pai = $h->private_attribute_info) { 413 push @attr_names, keys %$pai; 414 } 415 else { 416 push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []}; 417 } 418 if (my $fra = $self->{forced_response_attributes}) { 419 push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []} 420 } 421 $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type: @attr_names\n"); 422 423 # cache into the dbh even for sth, as the dbh is usually longer lived 424 return $dbh->{"private_gofer_std_attr_names_$h_type"} = \@attr_names; 425 } 426 427 428 sub execute_sth_request { 429 my ($self, $request) = @_; 430 my $dbh; 431 my $sth; 432 my $last_insert_id; 433 my $stats = $self->{stats}; 434 435 my $rv = eval { 436 $dbh = $self->_connect($request); 437 438 my $args = $request->dbh_method_call; # [ wantarray, 'method_name', @args ] 439 shift @$args; # discard wantarray 440 my $meth = shift @$args; 441 $stats->{method_calls_sth}->{$meth}++; 442 $sth = $dbh->$meth(@$args); 443 my $last = '(sth)'; # a true value (don't try to return actual sth) 444 445 # execute methods on the sth, e.g., bind_param & execute 446 if (my $calls = $request->sth_method_calls) { 447 for my $meth_call (@$calls) { 448 my $method = shift @$meth_call; 449 $stats->{method_calls_sth}->{$method}++; 450 $last = $sth->$method(@$meth_call); 451 } 452 } 453 454 if (my $lid_args = $request->dbh_last_insert_id_args) { 455 $stats->{method_calls_sth}->{last_insert_id}++; 456 $last_insert_id = $dbh->last_insert_id( @$lid_args ); 457 } 458 459 $last; 460 }; 461 my $response = $self->new_response_with_err($rv, $@, $dbh); 462 463 return $response if not $dbh; 464 465 $response->last_insert_id( $last_insert_id ) 466 if defined $last_insert_id; 467 468 # even if the eval failed we still want to try to gather attribute values 469 # (XXX would be nice to be able to support streaming of results. 470 # which would reduce memory usage and latency for large results) 471 if ($sth) { 472 $response->sth_resultsets( $self->gather_sth_resultsets($sth, $request, $response) ); 473 $sth->finish; 474 } 475 476 # does this request also want any dbh attributes returned? 477 my $dbh_attr_set; 478 if (my $dbh_attributes = $request->dbh_attributes) { 479 $dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes); 480 } 481 # XXX needs to be integrated with private_attribute_info() etc 482 if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) { 483 @{$dbh_attr_set}{@$dbh_attr} = $dbh->FETCH_many(@$dbh_attr); 484 } 485 $response->dbh_attributes($dbh_attr_set) if $dbh_attr_set && %$dbh_attr_set; 486 487 $self->reset_dbh($dbh); 488 489 return $response; 490 } 491 492 493 sub gather_sth_resultsets { 494 my ($self, $sth, $request, $response) = @_; 495 my $resultsets = eval { 496 497 my $attr_names = $self->_std_response_attribute_names($sth); 498 my $sth_attr = {}; 499 $sth_attr->{$_} = 1 for @$attr_names; 500 501 # let the client add/remove sth atributes 502 if (my $sth_result_attr = $request->sth_result_attr) { 503 $sth_attr->{$_} = $sth_result_attr->{$_} 504 for keys %$sth_result_attr; 505 } 506 my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr; 507 508 my $row_count = 0; 509 my $rs_list = []; 510 while (1) { 511 my $rs = $self->fetch_result_set($sth, \@sth_attr); 512 push @$rs_list, $rs; 513 if (my $rows = $rs->{rowset}) { 514 $row_count += @$rows; 515 } 516 last if $self->{forced_single_resultset}; 517 last if !($sth->more_results || $sth->{syb_more_results}); 518 } 519 520 my $stats = $self->{stats}; 521 $stats->{rows_returned_total} += $row_count; 522 $stats->{rows_returned_max} = $row_count 523 if $row_count > ($stats->{rows_returned_max}||0); 524 525 $rs_list; 526 }; 527 $response->add_err(1, $@) if $@; 528 return $resultsets; 529 } 530 531 532 sub fetch_result_set { 533 my ($self, $sth, $sth_attr) = @_; 534 my %meta; 535 eval { 536 @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr); 537 # we assume @$sth_attr contains NUM_OF_FIELDS 538 $meta{rowset} = $sth->fetchall_arrayref() 539 if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT 540 # the fetchall_arrayref may fail with a 'not executed' kind of error 541 # because gather_sth_resultsets/fetch_result_set are called even if 542 # execute() failed, or even if there was no execute() call at all. 543 # The corresponding error goes into the resultset err, not the top-level 544 # response err, so in most cases this resultset err is never noticed. 545 }; 546 if ($@) { 547 chomp $@; 548 $meta{err} = $DBI::err || 1; 549 $meta{errstr} = $DBI::errstr || $@; 550 $meta{state} = $DBI::state; 551 } 552 return \%meta; 553 } 554 555 556 sub _get_default_methods { 557 my ($dbh) = @_; 558 # returns a ref to a hash of dbh method names for methods which the driver 559 # hasn't overridden i.e., quote(). These don't need to be forwarded via gofer. 560 my $ImplementorClass = $dbh->{ImplementorClass} or die; 561 my %default_methods; 562 for my $method (@all_dbh_methods) { 563 my $dbi_sub = $all_dbh_methods{$method} || 42; 564 my $imp_sub = $ImplementorClass->can($method) || 42; 565 next if $imp_sub != $dbi_sub; 566 #warn("default $method\n"); 567 $default_methods{$method} = 1; 568 } 569 return \%default_methods; 570 } 571 572 573 # XXX would be nice to make this a generic DBI module 574 sub _install_rand_callbacks { 575 my ($self, $dbh, $dbi_gofer_random) = @_; 576 577 my $callbacks = $dbh->{Callbacks} || {}; 578 my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {}; 579 580 # return if we've already setup this handle with callbacks for these specs 581 return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random); 582 #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}"; 583 $callbacks->{_dbi_gofer_random_spec} = $dbi_gofer_random; 584 585 my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note); 586 my @specs = split /,/, $dbi_gofer_random; 587 for my $spec (@specs) { 588 if ($spec =~ m/^fail=(-?[.\d]+)%?$/) { 589 $fail_percent = $1; 590 $spec_part{fail} = $spec; 591 next; 592 } 593 if ($spec =~ m/^err=(-?\d+)$/) { 594 $fail_err = $1; 595 $spec_part{err} = $spec; 596 next; 597 } 598 if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) { 599 $delay_duration = $1; 600 $delay_percent = $2; 601 $spec_part{delay} = $spec; 602 next; 603 } 604 elsif ($spec !~ m/^(\w+|\*)$/) { 605 warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name"; 606 next; 607 } 608 609 my $method = $spec; 610 if ($callbacks->{$method} && $prev->{$method} && $callbacks->{$method} != $prev->{$method}) { 611 warn "Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n"; 612 next; 613 } 614 unless (defined $fail_percent or defined $delay_percent) { 615 warn "Ignored DBI_GOFER_RANDOM item '$spec' because not preceeded by 'fail=N' and/or 'delayN=N'"; 616 next; 617 } 618 619 push @spec_note, join(",", values(%spec_part), $method); 620 $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err); 621 } 622 warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n" 623 if @spec_note; 624 $dbh->{Callbacks} = $callbacks; 625 $dbh->{private_gofer_rand_fail_callbacks} = $callbacks; 626 } 627 628 my %_mk_rand_callback_seqn; 629 630 sub _mk_rand_callback { 631 my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_; 632 my ($fail_modrate, $delay_modrate); 633 $fail_percent ||= 0; $fail_modrate = int(1/(-$fail_percent )*100) if $fail_percent; 634 $delay_percent ||= 0; $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent; 635 # note that $method may be "*" but that's not recommended or documented or wise 636 return sub { 637 my ($h) = @_; 638 my $seqn = ++$_mk_rand_callback_seqn{$method}; 639 my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent : 640 ($delay_percent < 0) ? !($seqn % $delay_modrate): 0; 641 my $fail = ($fail_percent > 0) ? rand(100) < $fail_percent : 642 ($fail_percent < 0) ? !($seqn % $fail_modrate) : 0; 643 #no warnings 'uninitialized'; 644 #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay"; 645 if ($delay) { 646 my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n"; 647 # Note what's happening in a trace message. If the delay percent is an even 648 # number then use warn() instead so it's sent back to the client. 649 ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg); 650 select undef, undef, undef, $delay_duration; # allows floating point value 651 } 652 if ($fail) { 653 undef $_; # tell DBI to not call the method 654 # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr 655 # as it's checked for in a few places, such as the gofer retry logic 656 return $h->set_err($fail_err || $DBI::stderr, 657 "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)"); 658 } 659 return; 660 } 661 } 662 663 664 sub update_stats { 665 my ($self, 666 $request, $response, 667 $frozen_request, $frozen_response, 668 $time_received, 669 $store_meta, $other_meta, 670 ) = @_; 671 672 # should always have a response object here 673 carp("No response object provided") unless $request; 674 675 my $stats = $self->{stats}; 676 $stats->{frozen_request_max_bytes} = length($frozen_request) 677 if $frozen_request 678 && length($frozen_request) > ($stats->{frozen_request_max_bytes}||0); 679 $stats->{frozen_response_max_bytes} = length($frozen_response) 680 if $frozen_response 681 && length($frozen_response) > ($stats->{frozen_response_max_bytes}||0); 682 683 my $recent; 684 if (my $track_recent = $self->{track_recent}) { 685 $recent = { 686 request => $frozen_request, 687 response => $frozen_response, 688 time_received => $time_received, 689 duration => dbi_time()-$time_received, 690 # for any other info 691 ($store_meta) ? (meta => $store_meta) : (), 692 }; 693 $recent->{request_object} = $request 694 if !$frozen_request && $request; 695 $recent->{response_object} = $response 696 if !$frozen_response; 697 my @queues = ($stats->{recent_requests} ||= []); 698 push @queues, ($stats->{recent_errors} ||= []) 699 if !$response or $response->err; 700 for my $queue (@queues) { 701 push @$queue, $recent; 702 shift @$queue if @$queue > $track_recent; 703 } 704 } 705 return $recent; 706 } 707 708 709 1; 710 __END__ 711 712 =head1 NAME 713 714 DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses 715 716 =head1 SYNOPSIS 717 718 $executor = DBI::Gofer::Execute->new( { ...config... }); 719 720 $response = $executor->execute_request( $request ); 721 722 =head1 DESCRIPTION 723 724 Accepts a DBI::Gofer::Request object, executes the requested DBI method calls, 725 and returns a DBI::Gofer::Response object. 726 727 Any error, including any internal 'fatal' errors are caught and converted into 728 a DBI::Gofer::Response object. 729 730 This module is usually invoked by a 'server-side' Gofer transport module. 731 They usually have names in the "C<DBI::Gofer::Transport::*>" namespace. 732 Examples include: L<DBI::Gofer::Transport::stream> and L<DBI::Gofer::Transport::mod_perl>. 733 734 =head1 CONFIGURATION 735 736 =head2 check_request_sub 737 738 If defined, it must be a reference to a subroutine that will 'check' the request. 739 It is passed the request object and the executor as its only arguments. 740 741 The subroutine can either return the original request object or die with a 742 suitable error message (which will be turned into a Gofer response). 743 744 It can also construct and return a new request that should be executed instead 745 of the original request. 746 747 =head2 check_response_sub 748 749 If defined, it must be a reference to a subroutine that will 'check' the response. 750 It is passed the response object, the executor, and the request object. 751 The sub may alter the response object and return undef, or return a new response object. 752 753 This mechanism can be used to, for example, terminate the service if specific 754 database errors are seen. 755 756 =head2 forced_connect_dsn 757 758 If set, this DSN is always used instead of the one in the request. 759 760 =head2 default_connect_dsn 761 762 If set, this DSN is used if C<forced_connect_dsn> is not set and the request does not contain a DSN itself. 763 764 =head2 forced_connect_attributes 765 766 A reference to a hash of connect() attributes. Individual attributes in 767 C<forced_connect_attributes> will take precedence over corresponding attributes 768 in the request. 769 770 =head2 default_connect_attributes 771 772 A reference to a hash of connect() attributes. Individual attributes in the 773 request take precedence over corresponding attributes in C<default_connect_attributes>. 774 775 =head2 max_cached_dbh_per_drh 776 777 If set, the loaded drivers will be checked to ensure they don't have more than 778 this number of cached connections. There is no default value. This limit is not 779 enforced for every request. 780 781 =head2 max_cached_sth_per_dbh 782 783 If set, all the cached statement handles will be cleared once the number of 784 cached statement handles rises above this limit. The default is 1000. 785 786 =head2 forced_single_resultset 787 788 If true, then only the first result set will be fetched and returned in the response. 789 790 =head2 forced_response_attributes 791 792 A reference to a data structure that can specify extra attributes to be returned in responses. 793 794 forced_response_attributes => { 795 DriverName => { 796 dbh => [ qw(dbh_attrib_name) ], 797 sth => [ qw(sth_attrib_name) ], 798 }, 799 }, 800 801 This can be useful in cases where the driver has not implemented the 802 private_attribute_info() method and DBI::Gofer::Execute's own fallback list of 803 private attributes doesn't include the driver or attributes you need. 804 805 =head2 track_recent 806 807 If set, specifies the number of recent requests and responses that should be 808 kept by the update_stats() method for diagnostics. See L<DBI::Gofer::Transport::mod_perl>. 809 810 Note that this setting can significantly increase memory use. Use with caution. 811 812 =head2 forced_gofer_random 813 814 Enable forced random failures and/or delays for testing. See L</DBI_GOFER_RANDOM> below. 815 816 =head1 DRIVER-SPECIFIC ISSUES 817 818 Gofer needs to know about any driver-private attributes that should have their 819 values sent back to the client. 820 821 If the driver doesn't support private_attribute_info() method, and very few do, 822 then the module fallsback to using some hard-coded details, if available, for 823 the driver being used. Currently hard-coded details are available for the 824 mysql, Pg, Sybase, and SQLite drivers. 825 826 =head1 TESTING 827 828 DBD::Gofer, DBD::Execute and related packages are well tested by executing the 829 DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer. 830 831 Because Gofer includes timeout and 'retry on error' mechanisms there is a need 832 for some way to trigger delays and/or errors. This can be done via the 833 C<forced_gofer_random> configuration item, or else the DBI_GOFER_RANDOM environment 834 variable. 835 836 =head2 DBI_GOFER_RANDOM 837 838 The value of the C<forced_gofer_random> configuration item (or else the 839 DBI_GOFER_RANDOM environment variable) is treated as a series of tokens 840 separated by commas. 841 842 The tokens can be one of three types: 843 844 =over 4 845 846 =item fail=R% 847 848 Set the current failure rate to R where R is a percentage. 849 The value R can be floating point, e.g., C<fail=0.05%>. 850 Negative values for R have special meaning, see below. 851 852 =item err=N 853 854 Sets the current failure err vaue to N (instead of the DBI's default 'standard 855 err value' of 2000000000). This is useful when you want to simulate a 856 specific error. 857 858 =item delayN=R% 859 860 Set the current random delay rate to R where R is a percentage, and set the 861 current delay duration to N seconds. The values of R and N can be floating point, 862 e.g., C<delay0.5=0.2%>. Negative values for R have special meaning, see below. 863 864 If R is an odd number (R % 2 == 1) then a message is logged via warn() which 865 will be returned to, and echoed at, the client. 866 867 =item methodname 868 869 Applies the current fail, err, and delay values to the named method. 870 If neither a fail nor delay have been set yet then a warning is generated. 871 872 =back 873 874 For example: 875 876 $executor = DBI::Gofer::Execute->new( { 877 forced_gofer_random => "fail=0.01%,do,delay60=1%,execute", 878 }); 879 880 will cause the do() method to fail for 0.01% of calls, and the execute() method to 881 fail 0.01% of calls and be delayed by 60 seconds on 1% of calls. 882 883 If the percentage value (C<R>) is negative then instead of the failures being 884 triggered randomly (via the rand() function) they are triggered via a sequence 885 number. In other words "C<fail=-20%>" will mean every fifth call will fail. 886 Each method has a distinct sequence number. 887 888 =head1 AUTHOR 889 890 Tim Bunce, L<http://www.tim.bunce.name> 891 892 =head1 LICENCE AND COPYRIGHT 893 894 Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved. 895 896 This module is free software; you can redistribute it and/or 897 modify it under the same terms as Perl itself. See L<perlartistic>. 898 899 =cut
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |