[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