view release on metacpan or  search on metacpan

lib/DBI/Gofer/Execute.pm  view on Meta::CPAN

    }

    # 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->dbh_connect_call };
    $connect_method ||= 'connect_cached';
    $stats->{method_calls_dbh}->{$connect_method}++;

    # delete attributes we don'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->forced_connect_dsn || $dsn || $self->default_connect_dsn
        or die "No forced_connect_dsn, requested dsn, or default_connect_dsn for request";

    my $random = $self->{forced_gofer_random} || $ENV{DBI_GOFER_RANDOM} || '';

    my $connect_attr = {

        # the configured default attributes, if any
        %{ $self->default_connect_attributes },

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

        # the requested attributes
        %$attr,

        # force some attributes the way we'd like them
        PrintWarn  => $local_log,
        PrintError => $local_log,

        # the configured default attributes, if any
        %{ $self->forced_connect_attributes },

        # RaiseError must be enabled
        RaiseError => 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 => 0,

        # ensure this connect_cached doesn'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 => join("|", __PACKAGE__, $$, $random),
    };

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

    $dbh->{ShowErrorStatement} = 1 if $local_log;

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

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

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


sub reset_dbh {
    my ($self, $dbh) = @_;
    $dbh->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 .= "; $eval_error";
        }
        else {
            $errstr = $eval_error;
        }
    }
    chomp $errstr if $errstr;

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

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

    return $response;
}


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

lib/DBI/Gofer/Execute.pm  view on Meta::CPAN

                $row_count += @$rows;
            }
            last if $self->{forced_single_resultset};
            last if !($sth->more_results || $sth->{syb_more_results});
         }

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

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


sub fetch_result_set {
    my ($self, $sth, $sth_attr) = @_;
    my %meta;
    eval {
        @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr);
        # we assume @$sth_attr contains NUM_OF_FIELDS
        $meta{rowset}       = $sth->fetchall_arrayref()
            if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT
        # the fetchall_arrayref may fail with a 'not executed' 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't overridden i.e., quote(). These don't need to be forwarded via gofer.
    my $ImplementorClass = $dbh->{ImplementorClass} or die;
    my %default_methods;
    for my $method (@all_dbh_methods) {
        my $dbi_sub = $all_dbh_methods{$method}       || 42;
        my $imp_sub = $ImplementorClass->can($method) || 42;
        next if $imp_sub != $dbi_sub;
        #warn("default $method\n");
        $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->{Callbacks} || {};
    my $prev      = $dbh->{private_gofer_rand_fail_callbacks} || {};

    # return if we've already setup this handle with callbacks for these specs
    return if (($callbacks->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random);
    #warn "$dbh # $callbacks->{_dbi_gofer_random_spec}";
    $callbacks->{_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 "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config or a dbh method name";
            next;
        }

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

        push @spec_note, join(",", values(%spec_part), $method);
        $callbacks->{$method} = $self->_mk_rand_callback($method, $fail_percent, $delay_percent, $delay_duration, $fail_err);
    }
    warn "DBI_GOFER_RANDOM failures/delays enabled: @spec_note\n"
        if @spec_note;
    $dbh->{Callbacks} = $callbacks;
    $dbh->{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 "*" but that's not recommended or documented or wise
    return sub {
        my ($h) = @_;
        my $seqn = ++$_mk_rand_callback_seqn{$method};
        my $delay = ($delay_percent > 0) ? rand(100) < $delay_percent :
                    ($delay_percent < 0) ? !($seqn % $delay_modrate): 0;
        my $fail  = ($fail_percent  > 0) ? rand(100) < $fail_percent  :
                    ($fail_percent  < 0) ? !($seqn % $fail_modrate) : 0;
        #no warnings 'uninitialized';
        #warn "_mk_rand_callback($fail_percent:$fail_modrate, $delay_percent:$delay_modrate): seqn=$seqn fail=$fail delay=$delay";
        if ($delay) {
            my $msg = "DBI_GOFER_RANDOM delaying execution of $method() by $delay_duration seconds\n";
            # Note what's happening in a trace message. If the delay percent is an even
            # number then use warn() instead so it's sent back to the client.
            ($delay_percent % 2 == 1) ? warn($msg) : $h->trace_msg($msg);
            select undef, undef, undef, $delay_duration; # allows floating point value
        }
        if ($fail) {
            undef $_; # tell DBI to not call the method
            # the "induced by DBI_GOFER_RANDOM" is special and must be included in errstr
            # as it's checked for in a few places, such as the gofer retry logic
            return $h->set_err($fail_err || $DBI::stderr,
                "fake error from $method method induced by DBI_GOFER_RANDOM env var ($fail_percent%)");
        }
        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("No response object provided") unless $request;

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

    my $recent;
    if (my $track_recent = $self->{track_recent}) {
        $recent = {