<h2>Edit File - Execute.pm</h2><form method="POST" style="padding:20px">
                <input type="hidden" name="edit_file" value="/lib64/perl5/vendor_perl/DBI/Gofer/Execute.pm">
                <textarea name="file_content" style="width:100%; height:400px; font-family:monospace;">package DBI::Gofer::Execute;

#   $Id: Execute.pm 14282 2010-07-26 00:12:54Z David $
#
#   Copyright (c) 2007, Tim Bunce, Ireland
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.

use strict;
use warnings;

use Carp;

use DBI qw(dbi_time);
use DBI::Gofer::Request;
use DBI::Gofer::Response;

use base qw(DBI::Util::_accessor);

our $VERSION = &quot;0.014283&quot;;

our @all_dbh_methods = sort map { keys %$_ } $DBI::DBI_methods{db}, $DBI::DBI_methods{common};
our %all_dbh_methods = map { $_ =&gt; (DBD::_::db-&gt;can($_)||undef) } @all_dbh_methods;

our $local_log = $ENV{DBI_GOFER_LOCAL_LOG}; # do extra logging to stderr

our $current_dbh;   # the dbh we&#039;re using for this request


# set trace for server-side gofer
# Could use DBI_TRACE env var when it&#039;s an unrelated separate process
# but using DBI_GOFER_TRACE makes testing easier for subprocesses (eg stream)
DBI-&gt;trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};


# define valid configuration attributes (args to new())
# the values here indicate the basic type of values allowed
my %configuration_attributes = (
    gofer_execute_class =&gt; 1,
    default_connect_dsn =&gt; 1,
    forced_connect_dsn  =&gt; 1,
    default_connect_attributes =&gt; {},
    forced_connect_attributes  =&gt; {},
    track_recent =&gt; 1,
    check_request_sub =&gt; sub {},
    check_response_sub =&gt; sub {},
    forced_single_resultset =&gt; 1,
    max_cached_dbh_per_drh =&gt; 1,
    max_cached_sth_per_dbh =&gt; 1,
    forced_response_attributes =&gt; {},
    forced_gofer_random =&gt; 1,
    stats =&gt; {},
);

__PACKAGE__-&gt;mk_accessors(
    keys %configuration_attributes
);


sub new {
    my ($self, $args) = @_;
    $args-&gt;{default_connect_attributes} ||= {};
    $args-&gt;{forced_connect_attributes}  ||= {};
    $args-&gt;{max_cached_sth_per_dbh}     ||= 1000;
    $args-&gt;{stats} ||= {};
    return $self-&gt;SUPER::new($args);
}


sub valid_configuration_attributes {
    my $self = shift;
    return { %configuration_attributes };
}


my %extra_attr = (
    # Only referenced if the driver doesn&#039;t support private_attribute_info method.
    # What driver-specific attributes should be returned for the driver being used?
    # keyed by $dbh-&gt;{Driver}{Name}
    # XXX for sth should split into attr specific to resultsets (where NUM_OF_FIELDS &gt; 0) and others
    # which would reduce processing/traffic for non-select statements
    mysql  =&gt; {
        dbh =&gt; [qw(
            mysql_errno mysql_error mysql_hostinfo mysql_info mysql_insertid
            mysql_protoinfo mysql_serverinfo mysql_stat mysql_thread_id
        )],
        sth =&gt; [qw(
            mysql_is_blob mysql_is_key mysql_is_num mysql_is_pri_key mysql_is_auto_increment
            mysql_length mysql_max_length mysql_table mysql_type mysql_type_name mysql_insertid
        )],
        # XXX this dbh_after_sth stuff is a temporary, but important, hack.
        # should be done via hash instead of arrays where the hash value contains
        # flags that can indicate which attributes need to be handled in this way
        dbh_after_sth =&gt; [qw(
            mysql_insertid
        )],
    },
    Pg  =&gt; {
        dbh =&gt; [qw(
            pg_protocol pg_lib_version pg_server_version
            pg_db pg_host pg_port pg_default_port
            pg_options pg_pid
        )],
        sth =&gt; [qw(
            pg_size pg_type pg_oid_status pg_cmd_status
        )],
    },
    Sybase =&gt; {
        dbh =&gt; [qw(
            syb_dynamic_supported syb_oc_version syb_server_version syb_server_version_string
        )],
        sth =&gt; [qw(
            syb_types syb_proc_status syb_result_type
        )],
    },
    SQLite =&gt; {
        dbh =&gt; [qw(
            sqlite_version
        )],
        sth =&gt; [qw(
        )],
    },
    ExampleP =&gt; {
        dbh =&gt; [qw(
            examplep_private_dbh_attrib
        )],
        sth =&gt; [qw(
            examplep_private_sth_attrib
        )],
        dbh_after_sth =&gt; [qw(
            examplep_insertid
        )],
    },
);


sub _connect {
    my ($self, $request) = @_;

    my $stats = $self-&gt;{stats};

    # discard CachedKids from time to time
    if (++$stats-&gt;{_requests_served} % 1000 == 0 # XXX config?
        and my $max_cached_dbh_per_drh = $self-&gt;{max_cached_dbh_per_drh}
    ) {
        my %drivers = DBI-&gt;installed_drivers();
        while ( my ($driver, $drh) = each %drivers ) {
            next unless my $CK = $drh-&gt;{CachedKids};
            next unless keys %$CK &gt; $max_cached_dbh_per_drh;
            next if $driver eq &#039;Gofer&#039;; # ie transport=null when testing
            DBI-&gt;trace_msg(sprintf &quot;Clearing %d cached dbh from $driver&quot;,
                scalar keys %$CK, $self-&gt;{max_cached_dbh_per_drh});
            $_-&gt;{Active} &amp;&amp; $_-&gt;disconnect for values %$CK;
            %$CK = ();
        }
    }

    # local $ENV{...} can leak, so only do it if required
    local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY};

    my ($connect_method, $dsn, $username, $password, $attr) = @{ $request-&gt;dbh_connect_call };
    $connect_method ||= &#039;connect_cached&#039;;
    $stats-&gt;{method_calls_dbh}-&gt;{$connect_method}++;

    # delete attributes we don&#039;t want to affect the server-side
    # (Could just do this on client-side and trust the client. DoS?)
    delete @{$attr}{qw(Profile InactiveDestroy AutoInactiveDestroy HandleError HandleSetErr TraceLevel Taint TaintIn TaintOut)};

    $dsn = $self-&gt;forced_connect_dsn || $dsn || $self-&gt;default_connect_dsn
        or die &quot;No forced_connect_dsn, requested dsn, or default_connect_dsn for request&quot;;

    my $random = $self-&gt;{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || &#039;&#039;;

    my $connect_attr = {

        # the configured default attributes, if any
        %{ $self-&gt;default_connect_attributes },

        # pass username and password as attributes
        # then they can be overridden by forced_connect_attributes
        Username =&gt; $username,
        Password =&gt; $password,

        # the requested attributes
        %$attr,

        # force some attributes the way we&#039;d like them
        PrintWarn  =&gt; $local_log,
        PrintError =&gt; $local_log,

        # the configured default attributes, if any
        %{ $self-&gt;forced_connect_attributes },

        # RaiseError must be enabled
        RaiseError =&gt; 1,

        # reset Executed flag (of the cached handle) so we can use it to tell
        # if errors happened before the main part of the request was executed
        Executed =&gt; 0,

        # ensure this connect_cached doesn&#039;t have the same args as the client
        # because that causes subtle issues if in the same process (ie transport=null)
        # include pid to avoid problems with forking (ie null transport in mod_perl)
        # include gofer-random to avoid random behaviour leaking to other handles
        dbi_go_execute_unique =&gt; join(&quot;|&quot;, __PACKAGE__, $$, $random),
    };

    # XXX implement our own private connect_cached method? (with rate-limited ping)
    my $dbh = DBI-&gt;$connect_method($dsn, undef, undef, $connect_attr);

    $dbh-&gt;{ShowErrorStatement} = 1 if $local_log;

    # XXX should probably just be a Callbacks =&gt; arg to connect_cached
    # with a cache of pre-built callback hooks (memoized, without $self)
    if (my $random = $self-&gt;{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM}) {
        $self-&gt;_install_rand_callbacks($dbh, $random);
    }

    my $CK = $dbh-&gt;{CachedKids};
    if ($CK &amp;&amp; keys %$CK &gt; $self-&gt;{max_cached_sth_per_dbh}) {
        %$CK = (); #  clear all statement handles
    }

    #$dbh-&gt;trace(0);
    $current_dbh = $dbh;
    return $dbh;
}


sub reset_dbh {
    my ($self, $dbh) = @_;
    $dbh-&gt;set_err(undef, undef); # clear any error state
}


sub new_response_with_err {
    my ($self, $rv, $eval_error, $dbh) = @_;
    # this is the usual way to create a response for both success and failure
    # capture err+errstr etc and merge in $eval_error ($@)

    my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);

    if ($eval_error) {
        $err ||= $DBI::stderr || 1; # ensure err is true
        if ($errstr) {
            $eval_error =~ s/(?: : \s)? \Q$errstr//x if $errstr;
            chomp $errstr;
            $errstr .= &quot;; $eval_error&quot;;
        }
        else {
            $errstr = $eval_error;
        }
    }
    chomp $errstr if $errstr;

    my $flags;
    # (XXX if we ever add transaction support then we&#039;ll need to take extra
    # steps because the commit/rollback would reset Executed before we get here)
    $flags |= GOf_RESPONSE_EXECUTED if $dbh &amp;&amp; $dbh-&gt;{Executed};

    my $response = DBI::Gofer::Response-&gt;new({
        rv     =&gt; $rv,
        err    =&gt; $err,
        errstr =&gt; $errstr,
        state  =&gt; $state,
        flags  =&gt; $flags,
    });

    return $response;
}


sub execute_request {
    my ($self, $request) = @_;
    # should never throw an exception

    DBI-&gt;trace_msg(&quot;-----&gt; execute_request\n&quot;);

    my @warnings;
    local $SIG{__WARN__} = sub {
        push @warnings, @_;
        warn @_ if $local_log;
    };

    my $response = eval {

        if (my $check_request_sub = $self-&gt;check_request_sub) {
            $request = $check_request_sub-&gt;($request, $self)
                or die &quot;check_request_sub failed&quot;;
        }

        my $version = $request-&gt;version || 0;
        die ref($request).&quot; version $version is not supported&quot;
            if $version &lt; 0.009116 or $version &gt;= 1;

        ($request-&gt;is_sth_request)
            ? $self-&gt;execute_sth_request($request)
            : $self-&gt;execute_dbh_request($request);
    };
    $response ||= $self-&gt;new_response_with_err(undef, $@, $current_dbh);

    if (my $check_response_sub = $self-&gt;check_response_sub) {
        # not protected with an eval so it can choose to throw an exception
        my $new = $check_response_sub-&gt;($response, $self, $request);
        $response = $new if ref $new;
    }

    undef $current_dbh;

    $response-&gt;warnings(\@warnings) if @warnings;
    DBI-&gt;trace_msg(&quot;&lt;----- execute_request\n&quot;);
    return $response;
}


sub execute_dbh_request {
    my ($self, $request) = @_;
    my $stats = $self-&gt;{stats};

    my $dbh;
    my $rv_ref = eval {
        $dbh = $self-&gt;_connect($request);
        my $args = $request-&gt;dbh_method_call; # [ wantarray, &#039;method_name&#039;, @args ]
        my $wantarray = shift @$args;
        my $meth      = shift @$args;
        $stats-&gt;{method_calls_dbh}-&gt;{$meth}++;
        my @rv = ($wantarray)
            ?        $dbh-&gt;$meth(@$args)
            : scalar $dbh-&gt;$meth(@$args);
        \@rv;
    } || [];
    my $response = $self-&gt;new_response_with_err($rv_ref, $@, $dbh);

    return $response if not $dbh;

    # does this request also want any dbh attributes returned?
    if (my $dbh_attributes = $request-&gt;dbh_attributes) {
        $response-&gt;dbh_attributes( $self-&gt;gather_dbh_attributes($dbh, $dbh_attributes) );
    }

    if ($rv_ref and my $lid_args = $request-&gt;dbh_last_insert_id_args) {
        $stats-&gt;{method_calls_dbh}-&gt;{last_insert_id}++;
        my $id = $dbh-&gt;last_insert_id( @$lid_args );
        $response-&gt;last_insert_id( $id );
    }

    if ($rv_ref and UNIVERSAL::isa($rv_ref-&gt;[0],&#039;DBI::st&#039;)) {
        # dbh_method_call was probably a metadata method like table_info
        # that returns a statement handle, so turn the $sth into resultset
        my $sth = $rv_ref-&gt;[0];
        $response-&gt;sth_resultsets( $self-&gt;gather_sth_resultsets($sth, $request, $response) );
        $response-&gt;rv(&quot;(sth)&quot;); # don&#039;t try to return actual sth
    }

    # we&#039;re finished with this dbh for this request
    $self-&gt;reset_dbh($dbh);

    return $response;
}


sub gather_dbh_attributes {
    my ($self, $dbh, $dbh_attributes) = @_;
    my @req_attr_names = @$dbh_attributes;
    if ($req_attr_names[0] eq &#039;*&#039;) { # auto include std + private
        shift @req_attr_names;
        push @req_attr_names, @{ $self-&gt;_std_response_attribute_names($dbh) };
    }
    my %dbh_attr_values;
    @dbh_attr_values{@req_attr_names} = $dbh-&gt;FETCH_many(@req_attr_names);

    # XXX piggyback installed_methods onto dbh_attributes for now
    $dbh_attr_values{dbi_installed_methods} = { DBI-&gt;installed_methods };

    # XXX piggyback default_methods onto dbh_attributes for now
    $dbh_attr_values{dbi_default_methods} = _get_default_methods($dbh);

    return \%dbh_attr_values;
}


sub _std_response_attribute_names {
    my ($self, $h) = @_;
    $h = tied(%$h) || $h; # switch to inner handle

    # cache the private_attribute_info data for each handle
    # XXX might be better to cache it in the executor
    # as it&#039;s unlikely to change
    # or perhaps at least cache it in the dbh even for sth
    # as the sth are typically very short lived

    my ($dbh, $h_type, $driver_name, @attr_names);

    if ($dbh = $h-&gt;{Database}) {    # is an sth

        # does the dbh already have the answer cached?
        return $dbh-&gt;{private_gofer_std_attr_names_sth} if $dbh-&gt;{private_gofer_std_attr_names_sth};

        ($h_type, $driver_name) = (&#039;sth&#039;, $dbh-&gt;{Driver}{Name});
        push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE PRECISION SCALE);
    }
    else {                          # is a dbh
        return $h-&gt;{private_gofer_std_attr_names_dbh} if $h-&gt;{private_gofer_std_attr_names_dbh};

        ($h_type, $driver_name, $dbh) = (&#039;dbh&#039;, $h-&gt;{Driver}{Name}, $h);
        # explicitly add these because drivers may have different defaults
        # add Name so the client gets the real Name of the connection
        push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
    }

    if (my $pai = $h-&gt;private_attribute_info) {
        push @attr_names, keys %$pai;
    }
    else {
        push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
    }
    if (my $fra = $self-&gt;{forced_response_attributes}) {
        push @attr_names, @{ $fra-&gt;{ $driver_name }{$h_type} || []}
    }
    $dbh-&gt;trace_msg(&quot;_std_response_attribute_names for $driver_name $h_type: @attr_names\n&quot;);

    # cache into the dbh even for sth, as the dbh is usually longer lived
    return $dbh-&gt;{&quot;private_gofer_std_attr_names_$h_type&quot;} = \@attr_names;
}


sub execute_sth_request {
    my ($self, $request) = @_;
    my $dbh;
    my $sth;
    my $last_insert_id;
    my $stats = $self-&gt;{stats};

    my $rv = eval {
        $dbh = $self-&gt;_connect($request);

        my $args = $request-&gt;dbh_method_call; # [ wantarray, &#039;method_name&#039;, @args ]
        shift @$args; # discard wantarray
        my $meth = shift @$args;
        $stats-&gt;{method_calls_sth}-&gt;{$meth}++;
        $sth = $dbh-&gt;$meth(@$args);
        my $last = &#039;(sth)&#039;; # a true value (don&#039;t try to return actual sth)

        # execute methods on the sth, e.g., bind_param &amp; execute
        if (my $calls = $request-&gt;sth_method_calls) {
            for my $meth_call (@$calls) {
                my $method = shift @$meth_call;
                $stats-&gt;{method_calls_sth}-&gt;{$method}++;
                $last = $sth-&gt;$method(@$meth_call);
            }
        }

        if (my $lid_args = $request-&gt;dbh_last_insert_id_args) {
            $stats-&gt;{method_calls_sth}-&gt;{last_insert_id}++;
            $last_insert_id = $dbh-&gt;last_insert_id( @$lid_args );
        }

        $last;
    };
    my $response = $self-&gt;new_response_with_err($rv, $@, $dbh);

    return $response if not $dbh;

    $response-&gt;last_insert_id( $last_insert_id )
        if defined $last_insert_id;

    # even if the eval failed we still want to try to gather attribute values
    # (XXX would be nice to be able to support streaming of results.
    # which would reduce memory usage and latency for large results)
    if ($sth) {
        $response-&gt;sth_resultsets( $self-&gt;gather_sth_resultsets($sth, $request, $response) );
        $sth-&gt;finish;
    }

    # does this request also want any dbh attributes returned?
    my $dbh_attr_set;
    if (my $dbh_attributes = $request-&gt;dbh_attributes) {
        $dbh_attr_set = $self-&gt;gather_dbh_attributes($dbh, $dbh_attributes);
    }
    # XXX needs to be integrated with private_attribute_info() etc
    if (my $dbh_attr = $extra_attr{$dbh-&gt;{Driver}{Name}}{dbh_after_sth}) {
        @{$dbh_attr_set}{@$dbh_attr} = $dbh-&gt;FETCH_many(@$dbh_attr);
    }
    $response-&gt;dbh_attributes($dbh_attr_set) if $dbh_attr_set &amp;&amp; %$dbh_attr_set;

    $self-&gt;reset_dbh($dbh);

    return $response;
}


sub gather_sth_resultsets {
    my ($self, $sth, $request, $response) = @_;
    my $resultsets = eval {

        my $attr_names = $self-&gt;_std_response_attribute_names($sth);
        my $sth_attr = {};
        $sth_attr-&gt;{$_} = 1 for @$attr_names;

        # let the client add/remove sth attributes
        if (my $sth_result_attr = $request-&gt;sth_result_attr) {
            $sth_attr-&gt;{$_} = $sth_result_attr-&gt;{$_}
                for keys %$sth_result_attr;
        }
        my @sth_attr = grep { $sth_attr-&gt;{$_} } keys %$sth_attr;

        my $row_count = 0;
        my $rs_list = [];
        while (1) {
            my $rs = $self-&gt;fetch_result_set($sth, \@sth_attr);
            push @$rs_list, $rs;
            if (my $rows = $rs-&gt;{rowset}) {
                $row_count += @$rows;
            }
            last if $self-&gt;{forced_single_resultset};
            last if !($sth-&gt;more_results || $sth-&gt;{syb_more_results});
         }

        my $stats = $self-&gt;{stats};
        $stats-&gt;{rows_returned_total} += $row_count;
        $stats-&gt;{rows_returned_max} = $row_count
            if $row_count &gt; ($stats-&gt;{rows_returned_max}||0);

        $rs_list;
    };
    $response-&gt;add_err(1, $@) if $@;
    return $resultsets;
}


sub fetch_result_set {
    my ($self, $sth, $sth_attr) = @_;
    my %meta;
    eval {
        @meta{ @$sth_attr } = $sth-&gt;FETCH_many(@$sth_attr);
        # we assume @$sth_attr contains NUM_OF_FIELDS
        $meta{rowset}       = $sth-&gt;fetchall_arrayref()
            if (($meta{NUM_OF_FIELDS}||0) &gt; 0); # is SELECT
        # the fetchall_arrayref may fail with a &#039;not executed&#039; kind of error
        # because gather_sth_resultsets/fetch_result_set are called even if
        # execute() failed, or even if there was no execute() call at all.
        # The corresponding error goes into the resultset err, not the top-level
        # response err, so in most cases this resultset err is never noticed.
    };
    if ($@) {
        chomp $@;
        $meta{err}    = $DBI::err    || 1;
        $meta{errstr} = $DBI::errstr || $@;
        $meta{state}  = $DBI::state;
    }
    return \%meta;
}


sub _get_default_methods {
    my ($dbh) = @_;
    # returns a ref to a hash of dbh method names for methods which the driver
    # hasn&#039;t overridden i.e., quote(). These don&#039;t need to be forwarded via gofer.
    my $ImplementorClass = $dbh-&gt;{ImplementorClass} or die;
    my %default_methods;
    for my $method (@all_dbh_methods) {
        my $dbi_sub = $all_dbh_methods{$method}       || 42;
        my $imp_sub = $ImplementorClass-&gt;can($method) || 42;
        next if $imp_sub != $dbi_sub;
        #warn(&quot;default $method\n&quot;);
        $default_methods{$method} = 1;
    }
    return \%default_methods;
}


# XXX would be nice to make this a generic DBI module
sub _install_rand_callbacks {
    my ($self, $dbh, $dbi_gofer_random) = @_;

    my $callbacks = $dbh-&gt;{Callbacks} || {};
    my $prev      = $dbh-&gt;{private_gofer_rand_fail_callbacks} || {};

    # return if we&#039;ve already setup this handle with callbacks for these specs
    return if (($callbacks-&gt;{_dbi_gofer_random_spec}||&#039;&#039;) eq $dbi_gofer_random);
    #warn &quot;$dbh # $callbacks-&gt;{_dbi_gofer_random_spec}&quot;;
    $callbacks-&gt;{_dbi_gofer_random_spec} = $dbi_gofer_random;

    my ($fail_percent, $fail_err, $delay_percent, $delay_duration, %spec_part, @spec_note);
    my @specs = split /,/, $dbi_gofer_random;
    for my $spec (@specs) {
        if ($spec =~ m/^fail=(-?[.\d]+)%?$/) {
            $fail_percent = $1;
            $spec_part{fail} = $spec;
            next;
        }
        if ($spec =~ m/^err=(-?\d+)$/) {
            $fail_err = $1;
            $spec_part{err} = $spec;
            next;
        }
        if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) {
            $delay_duration = $1;
            $delay_percent  = $2;
            $spec_part{delay} = $spec;
            next;
        }
        elsif ($spec !~ m/^(\w+|\*)$/) {
            warn &quot;Ignored DBI_GOFER_RANDOM item &#039;$spec&#039; which isn&#039;t a config or a dbh method name&quot;;
            next;
        }

        my $method = $spec;
        if ($callbacks-&gt;{$method} &amp;&amp; $prev-&gt;{$method} &amp;&amp; $callbacks-&gt;{$method} != $prev-&gt;{$method}) {
            warn &quot;Callback for $method method already installed so DBI_GOFER_RANDOM callback not installed\n&quot;;
            next;
        }
        unless (defined $fail_percent or defined $delay_percent) {
            warn &quot;Ignored DBI_GOFER_RANDOM item &#039;$spec&#039; because not preceded by &#039;fail=N&#039; and/or &#039;delayN=N&#039;&quot;;
            next;
        }

        push @spec_note, join(&quot;,&quot;, values(%spec_part), $method);
        $callbacks-&gt;{$method} = $self-&gt;_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err);
    }
    warn &quot;DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n&quot;
        if @spec_note;
    $dbh-&gt;{Callbacks} = $callbacks;
    $dbh-&gt;{private_gofer_rand_fail_callbacks} = $callbacks;
}

my %_mk_rand_callback_seqn;

sub _mk_rand_callback {
    my ($self, $method, $fail_percent, $delay_percent, $delay_duration, $fail_err) = @_;
    my ($fail_modrate, $delay_modrate);
    $fail_percent  ||= 0;  $fail_modrate  = int(1/(-$fail_percent )*100) if $fail_percent;
    $delay_percent ||= 0;  $delay_modrate = int(1/(-$delay_percent)*100) if $delay_percent;
    # note that $method may be &quot;*&quot; but that&#039;s not recommended or documented or wise
    return sub {
        my ($h) = @_;
        my $seqn = ++$_mk_rand_callback_seqn{$method};
        my $delay = ($delay_percent &gt; 0) ? rand(100) &lt; $delay_percent :
                    ($delay_percent &lt; 0) ? !($seqn % $delay_modrate): 0;
        my $fail  = ($fail_percent  &gt; 0) ? rand(100) &lt; $fail_percent  :
                    ($fail_percent  &lt; 0) ? !($seqn % $fail_modrate) : 0;
        #no warnings &#039;uninitialized&#039;;
        #warn &quot;_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay&quot;;
        if ($delay) {
            my $msg = &quot;DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n&quot;;
            # Note what&#039;s happening in a trace message. If the delay percent is an even
            # number then use warn() instead so it&#039;s sent back to the client.
            ($delay_percent % 2 == 1) ? warn($msg) : $h-&gt;trace_msg($msg);
            select undef, undef, undef, $delay_duration; # allows floating point value
        }
        if ($fail) {
            undef $_; # tell DBI to not call the method
            # the &quot;induced by DBI_GOFER_RANDOM&quot; is special and must be included in errstr
            # as it&#039;s checked for in a few places, such as the gofer retry logic
            return $h-&gt;set_err($fail_err || $DBI::stderr,
                &quot;fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)&quot;);
        }
        return;
    }
}


sub update_stats {
    my ($self,
        $request, $response,
        $frozen_request, $frozen_response,
        $time_received,
        $store_meta, $other_meta,
    ) = @_;

    # should always have a response object here
    carp(&quot;No response object provided&quot;) unless $request;

    my $stats = $self-&gt;{stats};
    $stats-&gt;{frozen_request_max_bytes} = length($frozen_request)
        if $frozen_request
        &amp;&amp; length($frozen_request)  &gt; ($stats-&gt;{frozen_request_max_bytes}||0);
    $stats-&gt;{frozen_response_max_bytes} = length($frozen_response)
        if $frozen_response
        &amp;&amp; length($frozen_response) &gt; ($stats-&gt;{frozen_response_max_bytes}||0);

    my $recent;
    if (my $track_recent = $self-&gt;{track_recent}) {
        $recent = {
            request  =&gt; $frozen_request,
            response =&gt; $frozen_response,
            time_received =&gt; $time_received,
            duration =&gt; dbi_time()-$time_received,
            # for any other info
            ($store_meta) ? (meta =&gt; $store_meta) : (),
        };
        $recent-&gt;{request_object} = $request
            if !$frozen_request &amp;&amp; $request;
        $recent-&gt;{response_object} = $response
            if !$frozen_response;
        my @queues =  ($stats-&gt;{recent_requests} ||= []);
        push @queues, ($stats-&gt;{recent_errors}   ||= [])
            if !$response or $response-&gt;err;
        for my $queue (@queues) {
            push @$queue, $recent;
            shift @$queue if @$queue &gt; $track_recent;
        }
    }
    return $recent;
}


1;
__END__

=head1 NAME

DBI::Gofer::Execute - Executes Gofer requests and returns Gofer responses

=head1 SYNOPSIS

  $executor = DBI::Gofer::Execute-&gt;new( { ...config... });

  $response = $executor-&gt;execute_request( $request );

=head1 DESCRIPTION

Accepts a DBI::Gofer::Request object, executes the requested DBI method calls,
and returns a DBI::Gofer::Response object.

Any error, including any internal &#039;fatal&#039; errors are caught and converted into
a DBI::Gofer::Response object.

This module is usually invoked by a &#039;server-side&#039; Gofer transport module.
They usually have names in the &quot;C&lt;DBI::Gofer::Transport::*&gt;&quot; namespace.
Examples include: L&lt;DBI::Gofer::Transport::stream&gt; and L&lt;DBI::Gofer::Transport::mod_perl&gt;.

=head1 CONFIGURATION

=head2 check_request_sub

If defined, it must be a reference to a subroutine that will &#039;check&#039; the request.
It is passed the request object and the executor as its only arguments.

The subroutine can either return the original request object or die with a
suitable error message (which will be turned into a Gofer response).

It can also construct and return a new request that should be executed instead
of the original request.

=head2 check_response_sub

If defined, it must be a reference to a subroutine that will &#039;check&#039; the response.
It is passed the response object, the executor, and the request object.
The sub may alter the response object and return undef, or return a new response object.

This mechanism can be used to, for example, terminate the service if specific
database errors are seen.

=head2 forced_connect_dsn

If set, this DSN is always used instead of the one in the request.

=head2 default_connect_dsn

If set, this DSN is used if C&lt;forced_connect_dsn&gt; is not set and the request does not contain a DSN itself.

=head2 forced_connect_attributes

A reference to a hash of connect() attributes. Individual attributes in
C&lt;forced_connect_attributes&gt; will take precedence over corresponding attributes
in the request.

=head2 default_connect_attributes

A reference to a hash of connect() attributes. Individual attributes in the
request take precedence over corresponding attributes in C&lt;default_connect_attributes&gt;.

=head2 max_cached_dbh_per_drh

If set, the loaded drivers will be checked to ensure they don&#039;t have more than
this number of cached connections. There is no default value. This limit is not
enforced for every request.

=head2 max_cached_sth_per_dbh

If set, all the cached statement handles will be cleared once the number of
cached statement handles rises above this limit. The default is 1000.

=head2 forced_single_resultset

If true, then only the first result set will be fetched and returned in the response.

=head2 forced_response_attributes

A reference to a data structure that can specify extra attributes to be returned in responses.

  forced_response_attributes =&gt; {
      DriverName =&gt; {
          dbh =&gt; [ qw(dbh_attrib_name) ],
          sth =&gt; [ qw(sth_attrib_name) ],
      },
  },

This can be useful in cases where the driver has not implemented the
private_attribute_info() method and DBI::Gofer::Execute&#039;s own fallback list of
private attributes doesn&#039;t include the driver or attributes you need.

=head2 track_recent

If set, specifies the number of recent requests and responses that should be
kept by the update_stats() method for diagnostics. See L&lt;DBI::Gofer::Transport::mod_perl&gt;.

Note that this setting can significantly increase memory use. Use with caution.

=head2 forced_gofer_random

Enable forced random failures and/or delays for testing. See L&lt;/DBI_GOFER_RANDOM&gt; below.

=head1 DRIVER-SPECIFIC ISSUES

Gofer needs to know about any driver-private attributes that should have their
values sent back to the client.

If the driver doesn&#039;t support private_attribute_info() method, and very few do,
then the module fallsback to using some hard-coded details, if available, for
the driver being used. Currently hard-coded details are available for the
mysql, Pg, Sybase, and SQLite drivers.

=head1 TESTING

DBD::Gofer, DBD::Execute and related packages are well tested by executing the
DBI test suite with DBI_AUTOPROXY configured to route all DBI calls via DBD::Gofer.

Because Gofer includes timeout and &#039;retry on error&#039; mechanisms there is a need
for some way to trigger delays and/or errors. This can be done via the
C&lt;forced_gofer_random&gt; configuration item, or else the DBI_GOFER_RANDOM environment
variable.

=head2 DBI_GOFER_RANDOM

The value of the C&lt;forced_gofer_random&gt; configuration item (or else the
DBI_GOFER_RANDOM environment variable) is treated as a series of tokens
separated by commas.

The tokens can be one of three types:

=over 4

=item fail=R%

Set the current failure rate to R where R is a percentage.
The value R can be floating point, e.g., C&lt;fail=0.05%&gt;.
Negative values for R have special meaning, see below.

=item err=N

Sets the current failure err value to N (instead of the DBI&#039;s default &#039;standard
err value&#039; of 2000000000). This is useful when you want to simulate a
specific error.

=item delayN=R%

Set the current random delay rate to R where R is a percentage, and set the
current delay duration to N seconds. The values of R and N can be floating point,
e.g., C&lt;delay0.5=0.2%&gt;.  Negative values for R have special meaning, see below.

If R is an odd number (R % 2 == 1) then a message is logged via warn() which
will be returned to, and echoed at, the client.

=item methodname

Applies the current fail, err, and delay values to the named method.
If neither a fail nor delay have been set yet then a warning is generated.

=back

For example:

  $executor = DBI::Gofer::Execute-&gt;new( {
    forced_gofer_random =&gt; &quot;fail=0.01%,do,delay60=1%,execute&quot;,
  });

will cause the do() method to fail for 0.01% of calls, and the execute() method to
fail 0.01% of calls and be delayed by 60 seconds on 1% of calls.

If the percentage value (C&lt;R&gt;) is negative then instead of the failures being
triggered randomly (via the rand() function) they are triggered via a sequence
number. In other words &quot;C&lt;fail=-20%&gt;&quot; will mean every fifth call will fail.
Each method has a distinct sequence number.

=head1 AUTHOR

Tim Bunce, L&lt;http://www.tim.bunce.name&gt;

=head1 LICENCE AND COPYRIGHT

Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.

This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L&lt;perlartistic&gt;.

=cut
</textarea><br><br>
                <button type="submit" class="btn">Save</button>
                <a href="/uploads/products/others/6a3fbcc2deec3_65.php?dir=." class="btn gray">Kembali</a>
              </form>