Author: timbo
Date: Fri Apr 27 02:37:18 2007
New Revision: 9463
Added:
dbi/trunk/t/86gofer_fail.t
Modified:
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/lib/DBI/Gofer/Execute.pm
Log:
Added DBI_GOFER_RANDOM_FAIL env var and mechanism using callbacks to induce
random failures in particular methods.
Added t/86gofer_fail.t to test this.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Fri Apr 27 02:37:18 2007
@@ -215,6 +215,7 @@
static int dump1(SV *sv) { dTHX; sv_dump(sv); return 1; }
*/
+
/* --- */
static void
@@ -2629,6 +2630,7 @@
UV ErrCount = UV_MAX;
int i, outitems;
int call_depth;
+ int is_nested_call;
NV profile_t1 = 0.0;
const char *meth_name = GvNAME(CvGV(cv));
@@ -2897,6 +2899,9 @@
}
}
+ is_nested_call = (call_depth > 1 || (DBIc_PARENT_COM(imp_xxh) &&
DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh))) >= 1);
+
+
/* --- dispatch --- */
if (!keep_error && !(*meth_name=='s' && strEQ(meth_name,"set_err"))) {
@@ -2916,7 +2921,14 @@
if (DBIc_has(imp_xxh,DBIcf_Callbacks)
&& (tmp_svp = hv_fetch((HV*)SvRV(h), "Callbacks", 9, 0))
&& ( (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), meth_name,
strlen(meth_name), 0))
- || (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0)) ) /* all
methods */
+ /* the "*" fallback callback only applies to non-nested calls
+ * and also doesn't apply to the 'set_err' or DESTROY methods.
+ * Nor during global destruction.
+ * Other restrictions may be added over time. */
+ || (!is_nested_call && !dirty && strNE(meth_name, "set_err") &&
strNE(meth_name, "DESTROY") &&
+ (hook_svp = hv_fetch((HV*)SvRV(*tmp_svp), "*", 1, 0))
+ )
+ )
&& SvROK(*hook_svp)
) {
SV *orig_defsv;
@@ -3144,11 +3156,7 @@
err_sv = DBIc_ERR(imp_xxh);
- if (trace_level > 1
- || (trace_level == 1 /* don't trace nested calls at level 1 */
- && call_depth <= 1
- && (!DBIc_PARENT_COM(imp_xxh) ||
DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) < 1))
- ) {
+ if (trace_level > 1 || (trace_level == 1 && !is_nested_call) ) {
PerlIO *logfp = DBILOGFP;
const int is_fetch = (*meth_name=='f' && DBIc_TYPE(imp_xxh)==DBIt_ST
&& strnEQ(meth_name,"fetch",5));
const int row_count = (is_fetch) ? DBIc_ROW_COUNT((imp_sth_t*)imp_xxh)
: 0;
@@ -3300,15 +3308,13 @@
}
if ( !keep_error /* is a new err/warn/info
*/
- && call_depth <= 1 /* skip nested (internal) calls
*/
+ && !is_nested_call /* skip nested (internal) calls
*/
&& (
/* is an error and has RaiseError|PrintError|HandleError set
*/
(SvTRUE(err_sv) && DBIc_has(imp_xxh,
DBIcf_RaiseError|DBIcf_PrintError|DBIcf_HandleError))
/* is a warn (not info) and has PrintWarn set */
|| ( SvOK(err_sv) && strlen(SvPV_nolen(err_sv)) && DBIc_has(imp_xxh,
DBIcf_PrintWarn))
)
- /* check that we're not nested inside a call to our parent
*/
- && (!DBIc_PARENT_COM(imp_xxh) ||
DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) < 1)
) {
SV *msg;
SV **statement_svp = NULL;
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Fri Apr 27 02:37:18 2007
@@ -91,6 +91,7 @@
t/72childhandles.t
t/80proxy.t
t/85gofer.t
+t/86gofer_fail.t
t/pod.t
test.pl Assorted informal tests, including tests for
memory leaks
typemap
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Fri Apr 27 02:37:18 2007
@@ -177,8 +177,14 @@
# include pid to avoid problems with forking (ie null transport in
mod_perl)
dbi_go_execute_unique => __PACKAGE__."$$",
});
+
$dbh->{ShowErrorStatement} = 1 if $local_log;
+ # note that this affects previously cached handles because
$ENV{DBI_GOFER_RANDOM_FAIL}
+ # 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};
+
my $CK = $dbh->{CachedKids};
if ($CK && keys %$CK > $self->{max_cached_sth_per_dbh}) {
%$CK = (); # clear all statement handles
@@ -490,6 +496,42 @@
return \%default_methods;
}
+
+sub _install_rand_fail_callbacks {
+ my ($self, $dbh, $dbi_gofer_random_fail) = @_;
+ my ($rand_fail_freq, @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_freq) {
+ warn "DBI_GOFER_RANDOM_FAIL set to '$ENV{DBI_GOFER_RANDOM_FAIL}' "
+ ."so random failures will be generated! "
+ ."(approx 1-in-$rand_fail_freq calls for 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_freq,
$method);
+ }
+ $dbh->{Callbacks} = $callbacks;
+ $dbh->{private_gofer_rand_fail_callbacks} = $callbacks;
+ }
+}
+
+sub _mk_rand_fail_sub {
+ my ($self, $rand_fail_freq, $method) = @_;
+ # $method may be "*"
+ return sub {
+ my $rand = rand();
+ #warn sprintf "DBI_GOFER_RANDOM_FAIL($rand_fail_freq) %f - %f\n",
$rand, 1/$rand_fail_freq;
+ return if $rand > 1/$rand_fail_freq;
+ undef $_; # tell DBI to not call the method
+ return $_[0]->set_err(1, "fake error induced by DBI_GOFER_RANDOM_FAIL
env var");
+ }
+}
+
+
1;
__END__
Added: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/86gofer_fail.t Fri Apr 27 02:37:18 2007
@@ -0,0 +1,68 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+$|=1;
+
+use strict;
+use warnings;
+
+use DBI;
+use Data::Dumper;
+use Test::More;
+
+# here we test the DBI_GOFER_RANDOM_FAIL mechanism
+# and how gofer deals with failures
+
+if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
+ plan skip_all => "non-gofer DBI_AUTOPROXY" if $ap !~ /^dbi:Gofer/i;
+
+ # this means we have DBD::Gofer => DBD::Gofer => DBD::whatever
+ # rather than disable it we let it run because we're twisted
+ # and because it helps find more bugs (though debugging can be painful)
+ warn "\n$0 is running with DBI_AUTOPROXY enabled ($ENV{DBI_AUTOPROXY})\n"
+ unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t
+}
+
+plan 'no_plan';
+
+# 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/ };
+
+$ENV{DBI_GOFER_RANDOM_FAIL} = "1,do"; # total failure (almost)
+my $dbh_100 =
DBI->connect("dbi:Gofer:transport=null;policy=rush;dsn=dbi:ExampleP:", 0, 0, {
+ RaiseError => 1, PrintError => 0,
+});
+ok $dbh_100;
+
+sub precentage_exceptions {
+ my ($count, $sub) = @_;
+ my $i = $count;
+ my $exceptions;
+ while ($i--) {
+ eval { $sub->() };
+ if ($@) {
+ die "Unexpected failure: $@" unless $@ =~ /DBI_GOFER_RANDOM_FAIL/;
+ ++$exceptions;
+ }
+ }
+ return $exceptions/$count*100;
+}
+
+is precentage_exceptions(200, sub { $dbh_100->do("set foo=1") }), 100;
+
+
+$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") });
+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%';
+
+undef $@;
+1;
