Author: timbo
Date: Thu Jun 7 09:46:08 2007
New Revision: 9632
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/ProfileData.pm
dbi/trunk/t/05thrclone.t
dbi/trunk/t/86gofer_fail.t
Log:
Fixed execute_for_fetch() to not cache errstr values thanks to Bart Degryse.
Fixed t/86gofer_fail tests to be less likely to fail falsely.
Added non-random (deterministic) mode to DBI_GOFER_RANDOM mechanism.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Thu Jun 7 09:46:08 2007
@@ -43,12 +43,16 @@
Fixed XS versions of select*_*() methods to call execute()
fetch() etc., with inner handle instead of outer.
+ Fixed execute_for_fetch() to not cache errstr values
+ thanks to Bart Degryse.
Fixed unused var compiler warning thanks to JDHEDDEN.
+ Fixed t/86gofer_fail tests to be less likely to fail falsely.
Corrected timeout example in docs thanks to Egmont Koblinger.
Added support for !Time and !Time~N to DBI::Profile Path.
Added extra trace info to connect_cached thanks to Walery Studennikov.
+ Added non-random (deterministic) mode to DBI_GOFER_RANDOM mechanism.
DBI::ProfileDumper changes:
Don't write file if there's no profile data.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Thu Jun 7 09:46:08 2007
@@ -1921,7 +1921,7 @@
($tuple_status) ? @$tuple_status = () : $tuple_status = [];
my $rc_total = 0;
- my ($err_count, %errstr_cache);
+ my $err_count;
while ( my $tuple = &$fetch_tuple_sub() ) {
if ( my $rc = $sth->execute(@$tuple) ) {
push @$tuple_status, $rc;
@@ -1929,10 +1929,9 @@
}
else {
$err_count++;
- my $err = $sth->err;
- push @$tuple_status, [ $err, $errstr_cache{$err} ||=
$sth->errstr, $sth->state ];
+ push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ];
# XXX drivers implementing execute_for_fetch could opt to
"last;" here
- # if the know the error code means no further executes will
work.
+ # if they know the error code means no further executes will
work.
}
}
my $tuples = @$tuple_status;
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Thu Jun 7 09:46:08 2007
@@ -563,11 +563,11 @@
my ($fail_percent, $delay_percent, $delay_duration);
my @specs = split /,/, $dbi_gofer_random;
for my $spec (@specs) {
- if ($spec =~ m/^fail=([.\d]+)%?$/) {
+ if ($spec =~ m/^fail=(-?[.\d]+)%?$/) {
$fail_percent = $1;
next;
}
- if ($spec =~ m/^delay([.\d]+)=([.\d]+)%?$/) {
+ if ($spec =~ m/^delay([.\d]+)=(-?[.\d]+)%?$/) {
$delay_duration = $1;
$delay_percent = $2;
next;
@@ -592,20 +592,30 @@
$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_percent ||= 0; my $fail_modrate = int(1/(-$fail_percent )*100) if
$fail_percent;
+ $delay_percent ||= 0; my $delay_modrate = int(1/(-$delay_percent)*100) if
$delay_percent;
# note that $method may be "*"
return sub {
my ($h) = @_;
- if ($delay_percent && rand(100) < $delay_percent) {
+ 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 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) {
+ if ($fail) {
undef $_; # tell DBI to not call the method
return $h->set_err(1, "fake error induced by DBI_GOFER_RANDOM env
var");
}
@@ -767,13 +777,15 @@
=item fail=R%
-Set the current random failure rate to R where R is a percentage. The value R
can be floating point, e.g., C<fail=0.05%>.
+Set the current failure rate to R where R is a percentage.
+The value R can be floating point, e.g., C<fail=0.05%>.
+Negative values for R have special meaning, see below.
=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<delay120=0.1%>.
+e.g., C<delay120=0.1%>. Negative values for R have special meaning, see below.
=item methodname
@@ -791,6 +803,11 @@
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<R>) is negative then instead of the failures being
+triggered randomly (via the rand() function) they are triggered via a sequence
+number. In other words "C<fail=-20%>" will mean every fifth call will fail.
+Each method has a distinct sequence number.
+
=head1 AUTHOR
Tim Bunce, L<http://www.linkedin.com/in/timbunce>
Modified: dbi/trunk/lib/DBI/ProfileData.pm
==============================================================================
--- dbi/trunk/lib/DBI/ProfileData.pm (original)
+++ dbi/trunk/lib/DBI/ProfileData.pm Thu Jun 7 09:46:08 2007
@@ -192,7 +192,6 @@
# will clobber an existing $newfilename
rename($filename, $newfilename)
or croak "Can't rename($filename, $newfilename): $!";
- warn 42;
$filename = $newfilename;
}
Modified: dbi/trunk/t/05thrclone.t
==============================================================================
--- dbi/trunk/t/05thrclone.t (original)
+++ dbi/trunk/t/05thrclone.t Thu Jun 7 09:46:08 2007
@@ -24,8 +24,9 @@
# Something about DBD::Gofer causes a problem. Older versions didn't leak. It
# started at some point in development but I didn't track it down at the time
# so the exact change that made it start is now lost in the mists of time.
+# XXX doesn't seem to be happening any more
warn " You can ignore the $threads 'Scalars leaked' messages you may see here
(or send me a patch to fix the underlying problem)\n"
- if $ENV{DBI_AUTOPROXY} && not $ENV{DBI_PUREPERL};
+ if 0 && $ENV{DBI_AUTOPROXY} && not $ENV{DBI_PUREPERL};
{
package threads_sub;
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Thu Jun 7 09:46:08 2007
@@ -28,6 +28,7 @@
plan 'no_plan';
my $tmp;
+my $dbh;
my $fails;
# we'll use the null transport for simplicity and speed
@@ -39,45 +40,43 @@
# --- 100% failure rate
-$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,
-});
-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';
+($fails, $dbh) = trial_impact("fail=100%,do", 10, "", sub { $_->do("set
foo=1") });
+is $fails, 100, 'should fail 100% of the time';
+ok $@, '$@ should be set';
like $@, '/fake error induced by DBI_GOFER_RANDOM/';
-like $dbh_100->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain
DBI_GOFER_RANDOM';
+ok $dbh->errstr, 'errstr should be set';
+like $dbh->errstr, '/DBI_GOFER_RANDOM/', 'errstr should contain
DBI_GOFER_RANDOM';
+ok !$dbh->{go_response}->executed_flag_set, 'go_response executed flag should
be false';
-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;
# XXX randomness can't be predicted, so it's just possible these will fail
+srand(42); # try to limit occasional failures (effect will vary by platform
etc)
+
+sub trial_impact {
+ my ($spec, $count, $dsn_attr, $code) = @_;
+ local $ENV{DBI_GOFER_RANDOM} = $spec;
+ my $dbh = dbi_connect("policy=rush;$dsn_attr");
+ local $_ = $dbh;
+ my $fail_percent = percentage_exceptions(200, $code);
+ return $fail_percent unless wantarray;
+ return ($fail_percent, $dbh);
+}
# --- 50% failure rate, with no retries
-$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") });
+$fails = trial_impact("fail=50%,do", 200, "retry_limit=0", sub { $_->do("set
foo=1") });
print "target approx 50% random failures, got $fails%\n";
between_ok $fails, 10, 90, "should fail about 50% of the time, but at least
between 10% and 90%";
# --- 50% failure rate, with many retries (should yield low failure rate)
-$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->prepare("set foo=1") });
-print "target approx 5% random failures, got $fails%\n";
+$fails = trial_impact("fail=50%,prepare", 200, "retry_limit=5", sub {
$_->prepare("set foo=1") });
+print "target less than 20% effective random failures (ideally 0), 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"; # 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") });
+$fails = trial_impact("fail=10,do", 200, "retry_limit=10", sub { $_->do("set
foo=1") });
cmp_ok $fails, '<', 1, 'should fail < 1%';
# --- 50% failure rate, test is_idempotent
@@ -89,35 +88,53 @@
go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 },
ReadOnly => 1,
} );
-between_ok precentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }),
+between_ok percentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }),
10, 40, 'should fail ~25% (ie 50% with one retry)';
between_ok $dbh_50r1ro->{go_transport}->meta->{request_retry_count},
- 35, 65, 'transport request_retry_count should be around 50';
+ 20, 80, 'transport request_retry_count should be around 50';
# test as above but with ReadOnly => 0
ok my $dbh_50r1rw = dbi_connect("policy=rush;retry_limit=1", {
go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 },
ReadOnly => 0,
} );
-between_ok precentage_exceptions(100, sub { $dbh_50r1rw->do("set foo=1") }),
- 30, 70, 'should fail ~50%, ie no retries';
+between_ok percentage_exceptions(100, sub { $dbh_50r1rw->do("set foo=1") }),
+ 20, 80, 'should fail ~50%, ie no retries';
ok !$dbh_50r1rw->{go_transport}->meta->{request_retry_count},
'transport request_retry_count should be zero or undef';
+# --- check random is random and non-random is non-random
+
+my %fail_percents;
+for (1..5) {
+ $fails = trial_impact("fail=50%,do", 10, "", sub { $_->do("set foo=1") });
+ ++$fail_percents{$fails};
+}
+cmp_ok scalar keys %fail_percents, '>=', 2, 'positive percentage should fail
randomly';
+
+%fail_percents = ();
+for (1..5) {
+ $fails = trial_impact("fail=-50%,do", 10, "", sub { $_->do("set foo=1") });
+ ++$fail_percents{$fails};
+}
+is scalar keys %fail_percents, 1, 'negative percentage should fail
non-randomly';
+
# ---
print "Testing random delay\n";
$ENV{DBI_GOFER_RANDOM} = "delay0.1=51%,do"; # odd percentage to force warn()s
@warns = ();
-ok my $dbh = dbi_connect("policy=rush;retry_limit=0");
-is precentage_exceptions(20, sub { $dbh->do("set foo=1") }),
+ok $dbh = dbi_connect("policy=rush;retry_limit=0");
+is percentage_exceptions(20, 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, 19, 'should be delayed around 5 times';
+between_ok $delays, 1, 19, 'should be delayed around 5 times';
exit 0;
+# --- subs ---
+#
sub between_ok {
my ($got, $min, $max, $label) = @_;
local $Test::Builder::Level = 2;
@@ -132,7 +149,7 @@
});
}
-sub precentage_exceptions {
+sub percentage_exceptions {
my ($count, $sub) = @_;
my $i = $count;
my $exceptions = 0;
