Author: timbo
Date: Tue May 8 08:39:27 2007
New Revision: 9526
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.xs
dbi/trunk/Makefile.PL
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/t/86gofer_fail.t
Log:
Fixed printf arg warnings thanks to JDHEDDEN.
Added docs to DBD::Gofer::Transport::Base
Reworked DBI_GOFER_RANDOM_FAIL - it's now DBI_GOFER_RANDOM and can trigger both
delays and failures.
Added warning about utf8 locals possibly triggering test failures.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue May 8 08:39:27 2007
@@ -8,6 +8,8 @@
Assorted TODO notes:
+XXX write up DBI_GOFER_RANDOM
+
Policy principle:
Designed to influence behaviour of unaltered programs
ie go_* attributes take precidence over policy
@@ -39,7 +41,7 @@
Add trace modules that just records the last N trace messages into an array
and prepends them to any error message.
-=head2 Changes in DBI 1.55 (svn rev 9480), 1st May 2007
+=head2 Changes in DBI 1.55 (svn rev 9504), 4th May 2007
Fixed set_err() so HandleSetErr hook is executed reliably, if set.
Fixed accuracy of profiling when perl configured to use long doubles.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue May 8 08:39:27 2007
@@ -2930,8 +2930,8 @@
SV *code = SvRV(*hook_svp);
I32 skip_dispatch = 0;
if (trace_level)
- PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked (mark
%d)\n",
- (dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0), mark);
+ PerlIO_printf(DBILOGFP, "%c {{ %s callback %s being invoked\n",
+ (dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0));
/* we don't use ENTER,SAVETMPS & FREETMPS,LEAVE because we may need
mortal
* results to live long enough to be returned to our caller
@@ -2963,9 +2963,9 @@
DEFSV = SvREFCNT_inc(orig_defsv);
if (trace_level)
- PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s (mark
%d)\n",
+ PerlIO_printf(DBILOGFP, "%c }} %s callback %s returned%s\n",
(dirty?'!':' '), meth_name, neatsvpv(*hook_svp,0),
- skip_dispatch ? ", actual method will not be called" : "", mark
+ skip_dispatch ? ", actual method will not be called" : ""
);
if (skip_dispatch) { /* XXX experimental */
int ix = outitems;
Modified: dbi/trunk/Makefile.PL
==============================================================================
--- dbi/trunk/Makefile.PL (original)
+++ dbi/trunk/Makefile.PL Tue May 8 08:39:27 2007
@@ -50,6 +50,16 @@
}
+if (($ENV{LANG}||'') =~ m/utf-?8/i) {
+ print "\n";
+ print "*** Your LANG environment variable is set to '$ENV{LANG}'\a\n";
+ print "*** This is known to cause problems for some perl installations.\n";
+ print "*** If you get test failures, please try again with LANG unset.\n";
+ print "*** Please also email [EMAIL PROTECTED] and include the output of
'perl -V'\n";
+ print "\a\n";
+ sleep 4;
+}
+
if ($Config{useithreads}) {
print "\n";
print "*** You are using a perl configured with threading enabled.\a\n";
@@ -149,7 +159,7 @@
$opts{DEFINE} .= ' -Wmissing-noreturn -Wno-unused-parameter' if
$gccversion ge "3.0";
if ($is_developer && $::opt_g) {
$opts{DEFINE} .= ' -DPERL_GCC_PEDANTIC -ansi -pedantic' if $gccversion
ge "3.0";
- $opts{DEFINE} .= ' -Wdisabled-optimization' if $gccversion
ge "3.0";
+ $opts{DEFINE} .= ' -Wdisabled-optimization -Wformat' if $gccversion
ge "3.0";
$opts{DEFINE} .= ' -Wmissing-prototypes';
}
}
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 Tue May 8 08:39:27 2007
@@ -27,9 +27,15 @@
));
-
sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 }
+
+sub new_response {
+ my $self = shift;
+ return DBI::Gofer::Response->new(@_);
+}
+
+
sub transmit_request {
my ($self, $request) = @_;
my $to = $self->go_timeout;
@@ -51,7 +57,7 @@
if ($@) {
return $self->transport_timedout("transmit_request", $to)
if $@ eq "TIMEOUT\n";
- return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ return self->new_response({ err => 1, errstr => $@ });
}
return $response;
@@ -93,7 +99,7 @@
if ($@) {
return $self->transport_timedout("receive_response", $to)
if $@ eq "TIMEOUT\n";
- return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ return $self->new_response({ err => 1, errstr => $@ });
}
return $response;
};
@@ -128,7 +134,7 @@
if (not defined $retry) {
my $errstr = $response->errstr || '';
- $retry = 1 if $errstr =~ m/fake error induced by
DBI_GOFER_RANDOM_FAIL/;
+ $retry = 1 if $errstr =~ m/fake error induced by DBI_GOFER_RANDOM/;
}
if (not defined $retry) {
@@ -158,7 +164,7 @@
sub transport_timedout {
my ($self, $method, $timeout) = @_;
$timeout ||= $self->go_timeout;
- return DBI::Gofer::Response->new({ err => 1, errstr => "DBD::Gofer $method
timed-out after $timeout seconds" });
+ return $self->new_response({ err => 1, errstr => "DBD::Gofer $method
timed-out after $timeout seconds" });
}
@@ -168,6 +174,77 @@
DBD::Gofer::Transport::Base - base class for DBD::Gofer client transports
+=head1 SYNOPSIS
+
+ my $remote_dsn = "..."
+
DBI->connect("dbi:Gofer:transport=...;url=...;timeout=...;retry_limit=...;dsn=$remote_dsn",...)
+
+or, enable by setting the DBI_AUTOPROXY environment variable:
+
+ export DBI_AUTOPROXY='dbi:Gofer:transport=...;url=...'
+
+which will force I<all> DBI connections to be made via that Gofer server.
+
+=head1 DESCRIPTION
+
+This is the base class for all DBD::Gofer client transports.
+
+=head1 ATTRIBUTES
+
+Gofer transport attributes can be specified either in the attributes parameter
+of the connect() method call, or in the DSN string. When used in the DSN
+string, attribute names don't have the C<go_> prefix.
+
+=head2 go_dsn
+
+The full DBI DSN that the Gofer server should connect to on your behalf.
+
+When used in the DSN it must be the last element in the DSN string.
+
+=head2 go_timeout
+
+A time limit for sending a request and receiving a response. Some drivers may
+implement sending and receiving as separate steps, in which case (currently)
+the timeout applies to each separately.
+
+If a request needs to be resent then the timeout is restarted for each sending
+of a request and receiving of a response.
+
+=head2 go_retry_limit
+
+The maximum number of times an request may be retried. The default is 2.
+
+=head2 go_retry_hook
+
+This subroutine reference is called, if defined, for each response received
where $response->err is true.
+
+The subroutine is pass three parameters: the request object, the response
object, and the transport object.
+
+If it returns an undefined value then the default retry behaviour is used. See
L</RETRY ON ERROR> below.
+
+If it returns a defined but false value then the request is not resent.
+
+If it returns true value then the request is resent, so long as the number of
retries does not exceed C<go_retry_limit>.
+
+=head1 RETRY ON ERROR
+
+The default retry on error behaviour is:
+
+ - Retry if the error was due to DBI_GOFER_RANDOM. See L<DBI::Gofer::Execute>.
+
+ - Retry if $request->is_idempotent returns true. See L<DBI::Gofer::Request>.
+
+A retry won't be allowed if the number of previous retries has reached
C<go_retry_limit>.
+
+=head1 TRACING
+
+Tracing of gofer requests and reponses can be enabled by setting the
+C<DBD_GOFER_TRACE> environment variable. A value of 1 gives a reasonably
+compact summary o each request and response. A value of 2 or more gives a
+detailed, and voluminous, dump.
+
+The trace is written using DBI->trace_msg() and so is written to the default
+DBI trace output, which is usually STDERR.
=head1 AUTHOR AND COPYRIGHT
@@ -179,7 +256,7 @@
=head1 SEE ALSO
-L<DBD::Gofer>
+L<DBD::Gofer>, L<DBI::Gofer::Request>, L<DBI::Gofer::Response>,
L<DBI::Gofer::Execute>.
and some example transports:
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Tue May 8 08:39:27 2007
@@ -185,10 +185,10 @@
$dbh->{ShowErrorStatement} = 1 if $local_log;
- # note that this affects previously cached handles because
$ENV{DBI_GOFER_RANDOM_FAIL}
+ # note that this affects previously cached handles because
$ENV{DBI_GOFER_RANDOM}
# isn't included in the cache key. Could add a go_rand_fail=>... attribute.
- $self->_install_rand_fail_callbacks($dbh, $ENV{DBI_GOFER_RANDOM_FAIL})
- if $ENV{DBI_GOFER_RANDOM_FAIL};
+ $self->_install_rand_callbacks($dbh, $ENV{DBI_GOFER_RANDOM})
+ if $ENV{DBI_GOFER_RANDOM};
my $CK = $dbh->{CachedKids};
if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) {
@@ -504,38 +504,66 @@
}
-sub _install_rand_fail_callbacks {
- my ($self, $dbh, $dbi_gofer_random_fail) = @_;
- my ($rand_fail_pct, @rand_fail_methods) = split /,/,
$dbi_gofer_random_fail;
- @rand_fail_methods = qw(do prepare) if [EMAIL PROTECTED]; # only works for
dbh methods
- if ($rand_fail_pct) {
- warn "DBI_GOFER_RANDOM_FAIL set to '$ENV{DBI_GOFER_RANDOM_FAIL}' "
- ."so random failures will be generated! "
- ."(approx $rand_fail_pct% of calls to methods:
@rand_fail_methods)\n";
- my $callbacks = $dbh->{Callbacks} || {};
- my $prev = $dbh->{private_gofer_rand_fail_callbacks} || {};
- for my $method (@rand_fail_methods) {
- if ($callbacks->{$method} && $callbacks->{$method} !=
$prev->{$method}) {
- warn "Callback for $method method already installed so
DBI_GOFER_RANDOM_FAIL callback not installed\n";
- next;
- }
- $callbacks->{$method} = $self->_mk_rand_fail_sub($rand_fail_pct,
$method);
+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 (($prev->{_dbi_gofer_random_spec}||'') eq $dbi_gofer_random);
+ $prev->{_dbi_gofer_random_spec} = $dbi_gofer_random;
+
+ my ($fail_percent, $delay_percent, $delay_duration);
+ my @specs = split /,/, $dbi_gofer_random;
+ for my $spec (@specs) {
+ if ($spec =~ m/^fail=([.\d]+)%?$/) {
+ $fail_percent = $1;
+ next;
+ }
+ if ($spec =~ m/^delay([.\d]+)=([.\d]+)%?$/) {
+ $delay_duration = $1;
+ $delay_percent = $2;
+ next;
+ }
+ elsif ($spec !~ m/^(\w+|\*)$/) {
+ warn "Ignored DBI_GOFER_RANDOM item '$spec' which isn't a config
or a dbh method name";
+ next;
}
- $dbh->{Callbacks} = $callbacks;
- $dbh->{private_gofer_rand_fail_callbacks} = $callbacks;
+ my $method = $spec;
+ if ($callbacks->{$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 preceeded
by 'fail=N' and/or 'delayN=N'";
+ next;
+ }
+ warn "DBI_GOFER_RANDOM enabled for $method() - random failures/delays
will be generated!\n";
+ $callbacks->{$method} = $self->_mk_rand_callback($method,
$fail_percent, $delay_percent, $delay_duration);
}
+ $dbh->{Callbacks} = $callbacks;
+ $dbh->{private_gofer_rand_fail_callbacks} = $callbacks;
}
-sub _mk_rand_fail_sub {
- my ($self, $rand_fail_pct, $method) = @_;
- my $rand_fail_ratio = $rand_fail_pct/100;
- # $method may be "*"
+
+sub _mk_rand_callback {
+ my ($self, $method, $fail_percent, $delay_percent, $delay_duration) = @_;
+ # note that $method may be "*"
return sub {
- my $rand = rand();
- #warn sprintf "DBI_GOFER_RANDOM_FAIL($rand_fail_pct) %f - %f\n",
$rand, 1/$rand_fail_pct;
- return if $rand >= $rand_fail_ratio;
- undef $_; # tell DBI to not call the method
- return $_[0]->set_err(1, "fake error induced by DBI_GOFER_RANDOM_FAIL
env var");
+ my ($h) = @_;
+ if ($delay_percent && rand(100) < $delay_percent) {
+ 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 odd
+ # number then use warn() so it's sent back to the client
+ ($delay_percent % 2 == 0) ? $h->trace_msg($msg) : warn($msg);
+ select undef, undef, undef, $delay_duration; # allows floating
point value
+ }
+ if ($fail_percent && rand(100) < $fail_percent) {
+ undef $_; # tell DBI to not call the method
+ return $h->set_err(1, "fake error induced by DBI_GOFER_RANDOM env
var");
+ }
+ return;
}
}
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Tue May 8 08:39:27 2007
@@ -10,7 +10,7 @@
use Test::More;
sub between_ok;
-# here we test the DBI_GOFER_RANDOM_FAIL mechanism
+# here we test the DBI_GOFER_RANDOM mechanism
# and how gofer deals with failures
plan skip_all => "requires Callbacks which are not supported with PurePerl" if
$DBI::PurePerl;
@@ -33,12 +33,13 @@
# we'll use the null transport for simplicity and speed
# and the rush policy to limit the number of interactions with the gofer
executor
-# silence the "DBI_GOFER_RANDOM_FAIL set ..." warning
-$SIG{__WARN__} = sub { warn "@_" unless "@_" =~ /^DBI_GOFER_RANDOM_FAIL set/ };
+# silence the "DBI_GOFER_RANDOM..." warnings
+my @warns;
+$SIG{__WARN__} = sub { ("@_" =~ /^DBI_GOFER_RANDOM/) ? push(@warns, @_) : warn
@_; };
# --- 100% failure rate
-$ENV{DBI_GOFER_RANDOM_FAIL} = "100,do"; # total failure (almost)
+$ENV{DBI_GOFER_RANDOM} = "fail=100%,do"; # total failure
my $dbh_100 =
DBI->connect("dbi:Gofer:transport=null;policy=rush;dsn=dbi:ExampleP:", 0, 0, {
RaiseError => 1, PrintError => 0,
});
@@ -47,8 +48,8 @@
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';
+like $@, '/fake error induced by DBI_GOFER_RANDOM/';
+like $dbh_100->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain
DBI_GOFER_RANDOM';
ok !$dbh_100->{go_response}->executed_flag_set, 'go_response executed flag
should be false';
@@ -58,7 +59,7 @@
# --- 50% failure rate, with no retries
-$ENV{DBI_GOFER_RANDOM_FAIL} = "50,do"; # 50% failure (almost)
+$ENV{DBI_GOFER_RANDOM} = "fail=50%,do"; # 50% failure (almost)
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";
@@ -66,22 +67,22 @@
# --- 50% failure rate, with many retries (should yield low failure rate)
-$ENV{DBI_GOFER_RANDOM_FAIL} = "50,do"; # 50% failure (almost)
+$ENV{DBI_GOFER_RANDOM} = "fail=50%,prepare"; # 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") });
+$fails = precentage_exceptions(200, sub { $dbh_50r5->prepare("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";
+$ENV{DBI_GOFER_RANDOM} = "fail=10,do"; # without the % this time
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%';
# --- 50% failure rate, test is_idempotent
-$ENV{DBI_GOFER_RANDOM_FAIL} = "50,do"; # 50%
+$ENV{DBI_GOFER_RANDOM} = "fail=50%,do"; # 50%
# test go_retry_hook and that ReadOnly => 1 retries a non-idempotent statement
ok my $dbh_50r1ro = dbi_connect("policy=rush;retry_limit=1", {
@@ -104,7 +105,16 @@
'transport request_retry_count should be zero or undef';
+# ---
+print "Testing random delay\n";
+$ENV{DBI_GOFER_RANDOM} = "delay0.1=51%,do"; # odd percentage to force warn()s
[EMAIL PROTECTED] = ();
+ok my $dbh = dbi_connect("policy=rush;retry_limit=0");
+is precentage_exceptions(10, sub { $dbh->do("set foo=1") }),
+ 0, "should not fail for DBI_GOFER_RANDOM='$ENV{DBI_GOFER_RANDOM}'";
+my $delays = grep { m/delaying execution/ } @warns;
+between_ok $delays, 2, 9, 'should be delayed around 5 times';
exit 0;
@@ -129,7 +139,7 @@
while ($i--) {
eval { $sub->() };
if ($@) {
- die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM_FAIL/;
+ die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM/;
++$exceptions;
}
}
