Author: timbo
Date: Fri Apr 27 05:25:17 2007
New Revision: 9465
Modified:
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/Util/_accessor.pm
dbi/trunk/t/86gofer_fail.t
Log:
Add automatic retries on failure - works very well.
Currently the response_needs_retransmit method only knows to retry
DBI_GOFER_RANDOM_FAIL errors.
Add retry_limit=N to gofer dsn.
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Fri Apr 27 05:25:17 2007
@@ -266,8 +266,8 @@
my $transport = $dbh->{go_transport}
or return $dbh->set_err(1, "Not connected (no transport)");
- my $response = $transport->transmit_request($request);
- $response ||= $transport->receive_response;
+ my ($response, $retransmit_sub) =
$transport->transmit_request($request);
+ $response ||= $transport->receive_response($request, $retransmit_sub);
$dbh->{go_response} = $response
or die "No response object returned by $transport";
@@ -584,8 +584,8 @@
my $transport = $sth->{go_transport}
or return $sth->set_err(1, "Not connected (no transport)");
- my $response = $transport->transmit_request($request);
- $response ||= $transport->receive_response;
+ my ($response, $retransmit_sub) =
$transport->transmit_request($request);
+ $response ||= $transport->receive_response($request, $retransmit_sub);
$sth->{go_response} = $response
or die "No response object returned by $transport";
$dbh->{go_response} = $response; # mainly for last_insert_id
Modified: dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/Base.pm Fri Apr 27 05:25:17 2007
@@ -19,6 +19,7 @@
go_dsn
go_url
go_timeout
+ go_retry_limit
));
@@ -29,9 +30,10 @@
my $to = $self->go_timeout;
my $transmit_sub = sub {
+ $self->trace_msg("transmit_request\n");
local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
- my $info = eval {
+ my $response = eval {
local $SIG{PIPE} = sub {
my $extra = ($! eq "Broken pipe") ? "" : " ($!)";
die "Unable to send request: Broken pipe$extra\n";
@@ -47,38 +49,93 @@
return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
}
- return undef;
+ return $response;
};
- my $response = $transmit_sub->();
+ my $response = $self->_transmit_request_with_retries($request,
$transmit_sub);
+
+ $self->trace_msg("transmit_request is returing a response itself\n") if
$response;
return $response unless wantarray;
return ($response, $transmit_sub);
}
-sub receive_response {
- my $self = shift;
+sub _transmit_request_with_retries {
+ my ($self, $request, $transmit_sub) = @_;
+ my $response;
+ do {
+ $response = $transmit_sub->();
+ } while ( $response && $self->response_needs_retransmit($response,
$request) );
+ return $response;
+}
+
+sub receive_response {
+ my ($self, $request, $retransmit_sub) = @_;
my $to = $self->go_timeout;
- local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
- my $response = eval {
- alarm($to) if $to;
- $self->receive_response_by_transport();
+ my $receive_sub = sub {
+ $self->trace_msg("receive_response\n");
+ local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
+
+ my $response = eval {
+ alarm($to) if $to;
+ $self->receive_response_by_transport();
+ };
+ alarm(0) if $to;
+
+ if ($@) {
+ return $self->transport_timedout("receive_response", $to)
+ if $@ eq "TIMEOUT\n";
+ return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ }
+ return $response;
};
- alarm(0) if $to;
- if ($@) {
- return $self->transport_timedout("receive_response", $to)
- if $@ eq "TIMEOUT\n";
- return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
- }
+ my $response;
+ do {
+ $response = $receive_sub->();
+ if ($self->response_needs_retransmit($response, $request)) {
+ $response = $self->_transmit_request_with_retries($request,
$retransmit_sub);
+ $response ||= $receive_sub->();
+ }
+ } while ( $self->response_needs_retransmit($response, $request) );
return $response;
}
+sub response_needs_retransmit {
+ my ($self, $response, $request) = @_;
+
+ my $err = $response->err
+ or return 0; # nothing wen't wrong
+
+ my $retry;
+ my $errstr = $response->errstr || '';
+
+ my $idempotent = 0; # XXX set to 1 for idempotent requests, ie selects
+
+ $retry = 1 if $errstr =~ m/fake error induced by DBI_GOFER_RANDOM_FAIL/;
+
+ if (!$retry) {
+ $self->trace_msg("response_needs_retransmit: response not suitable for
retry\n");
+ return 0;
+ }
+ my $meta = $request->meta;
+ my $retry_count = ++$meta->{retry_count};
+ my $retry_limit = $self->go_retry_limit;
+ $retry_limit = 2 unless defined $retry_limit;
+ if ($retry_count > $retry_limit) {
+ $self->trace_msg("response_needs_retransmit: $retry_count is too many
retries\n");
+ return 0;
+ }
+ $self->trace_msg("response_needs_retransmit: retry $retry_count\n");
+ return 1;
+}
+
+
sub transport_timedout {
my ($self, $method, $timeout) = @_;
$timeout ||= $self->go_timeout;
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Fri Apr 27 05:25:17 2007
@@ -25,6 +25,9 @@
sth_method_calls
sth_result_attr
));
+__PACKAGE__->mk_accessors_with(make_accessor_autoviv_hashref => qw(
+ meta
+));
sub new {
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Fri Apr 27 05:25:17 2007
@@ -33,6 +33,9 @@
sth_resultsets
warnings
));
+__PACKAGE__->mk_accessors_with(make_accessor_autoviv_hashref => qw(
+ meta
+));
sub new {
Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Fri Apr 27 05:25:17 2007
@@ -64,9 +64,10 @@
$self->_dump("freezing $self->{trace} ".ref($data), $data)
if !$skip_trace and $self->trace;
- my $header = $packet_header_text;
+ local $data->{meta}; # don't include _meta in serialization
my $data = $self->{serializer_obj}->serializer($data);
- $header.$data;
+
+ $packet_header_text . $data;
};
if ($@) {
chomp $@;
Modified: dbi/trunk/lib/DBI/Util/_accessor.pm
==============================================================================
--- dbi/trunk/lib/DBI/Util/_accessor.pm (original)
+++ dbi/trunk/lib/DBI/Util/_accessor.pm Fri Apr 27 05:25:17 2007
@@ -19,10 +19,10 @@
sub mk_accessors {
my($self, @fields) = @_;
- $self->_mk_accessors('make_accessor', @fields);
+ $self->mk_accessors_with('make_accessor', @fields);
}
-sub _mk_accessors {
+sub mk_accessors_with {
my($self, $maker, @fields) = @_;
my $class = ref $self || $self;
@@ -47,7 +47,18 @@
return sub {
my $self = shift;
return $self->{$field} unless @_;
- $self->{$field} = (@_ == 1 ? $_[0] : [EMAIL PROTECTED]);
+ croak "Too many arguments to $field" if @_ > 1;
+ return $self->{$field} = shift;
+ };
+}
+
+sub make_accessor_autoviv_hashref {
+ my($class, $field) = @_;
+ return sub {
+ my $self = shift;
+ return $self->{$field} ||= {} unless @_;
+ croak "Too many arguments to $field" if @_ > 1;
+ return $self->{$field} = shift;
};
}
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Fri Apr 27 05:25:17 2007
@@ -24,6 +24,9 @@
plan 'no_plan';
+my $tmp;
+my $fails;
+
# we'll use the null transport for simplicity and speed
# and the rush policy to limit the number of interactions with the gofer
executor
@@ -39,30 +42,55 @@
ok $dbh_100;
ok !eval { $dbh_100->do("set foo=1") }, 'do method should fail';
+ok $dbh_100->errstr, 'errstr should be set';
+ok $@, '$@ should be set';
+like $@, '/fake error induced by DBI_GOFER_RANDOM_FAIL/';
like $dbh_100->errstr, '/DBI_GOFER_RANDOM_FAIL/', 'errstr should contain
DBI_GOFER_RANDOM_FAIL';
+
ok !$dbh_100->{go_response}->executed_flag_set, 'go_response executed flag
should be false';
is precentage_exceptions(200, sub { $dbh_100->do("set foo=1") }), 100;
-# --- 50% failure rate
+# XXX randomness can't be predicted, so it's just possible these will fail
+
+# --- 50% failure rate, with no retries
$ENV{DBI_GOFER_RANDOM_FAIL} = "2,do"; # 50% failure (almost)
-my $dbh_50 =
DBI->connect("dbi:Gofer:transport=null;policy=rush;dsn=dbi:ExampleP:", 0, 0, {
- RaiseError => 1, PrintError => 0,
-});
-ok $dbh_50;
-my $fails = precentage_exceptions(200, sub { $dbh_50->do("set foo=1") });
+ok my $dbh_50r0 = dbi_connect("policy=rush;retry_limit=0");
+$fails = precentage_exceptions(200, sub { $dbh_50r0->do("set foo=1") });
print "target approx 50% random failures, got $fails%\n";
-# XXX randomness can't be predicted, so it's just possible these will fail
cmp_ok $fails, '>', 10, 'should fail about 50% of the time, but at least 10%';
cmp_ok $fails, '<', 90, 'should fail about 50% of the time, but not more than
90%';
+# --- 50% failure rate, with many retries (should yield low failure rate)
+
+$ENV{DBI_GOFER_RANDOM_FAIL} = "2,do"; # 50% failure (almost)
+ok my $dbh_50r5 = dbi_connect("policy=rush;retry_limit=5");
+$fails = precentage_exceptions(200, sub { $dbh_50r5->do("set foo=1") });
+print "target approx 5% random failures, got $fails%\n";
+cmp_ok $fails, '<', 20, 'should fail < 20%';
+
+# --- 10% failure rate, with many retries (should yield zero failure rate)
+
+$ENV{DBI_GOFER_RANDOM_FAIL} = "10,do";
+ok my $dbh_1r10 = dbi_connect("policy=rush;retry_limit=10");
+$fails = precentage_exceptions(200, sub { $dbh_1r10->do("set foo=1") });
+cmp_ok $fails, '<', 1, 'should fail < 1%';
+
+
exit 0;
+sub dbi_connect {
+ my ($gdsn) = @_;
+ return DBI->connect("dbi:Gofer:transport=null;$gdsn;dsn=dbi:ExampleP:", 0,
0, {
+ RaiseError => 1, PrintError => 0,
+ });
+}
+
sub precentage_exceptions {
my ($count, $sub) = @_;
my $i = $count;
- my $exceptions;
+ my $exceptions = 0;
while ($i--) {
eval { $sub->() };
if ($@) {
