view release on metacpan or  search on metacpan

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

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


1;
__END__

=head1 NAME

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

=head1 SYNOPSIS

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

  $response = $executor->execute_request( $request );

=head1 DESCRIPTION

Accepts a DBI::Gofer::Request object, executes the requested DBI method calls,