Author: timbo
Date: Fri Apr 27 03:10:50 2007
New Revision: 9464
Modified:
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/t/70callbacks.t
dbi/trunk/t/85gofer.t
dbi/trunk/t/86gofer_fail.t
Log:
Move setting Executed fag to after Callback handling so flag not set if
callback skips the method.
Add executed_flag_set accessor method to gofe Response class.
Add tests for it.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Apr 27 03:10:50 2007
@@ -3341,11 +3341,10 @@
same time. So calling execute() on a $sth also sets the C<Executed>
attribute on the parent $dbh.
-The C<Executed> attribute for a database handle is cleared by the
-commit() and rollback() methods. The C<Executed> attribute of a
-statement handle is not cleared by the DBI under any circumstances
-and so acts as a permanent record of whether the statement handle
-was ever used.
+The C<Executed> attribute for a database handle is cleared by the commit() and
+rollback() methods (even if they fail). The C<Executed> attribute of a
+statement handle is not cleared by the DBI under any circumstances and so acts
+as a permanent record of whether the statement handle was ever used.
The C<Executed> attribute was added in DBI 1.41.
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Fri Apr 27 03:10:50 2007
@@ -2773,7 +2773,7 @@
/* Check method call against Internal Method Attributes */
if (ima) {
- if (ima_flags &
(IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT|IMA_EXECUTE))
{
+ if (ima_flags &
(IMA_STUB|IMA_FUNC_REDIRECT|IMA_KEEP_ERR|IMA_KEEP_ERR_SUB|IMA_CLEAR_STMT)) {
if (ima_flags & IMA_STUB) {
if (*meth_name == 'c' && strEQ(meth_name,"can")) {
@@ -2807,12 +2807,6 @@
neatsvpv(h,0), meth_name, neatsvpv(meth_name_sv,0));
meth_name = SvPV_nolen(meth_name_sv);
}
- if (ima_flags & IMA_EXECUTE) {
- imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh);
- DBIc_on(imp_xxh, DBIcf_Executed);
- if (parent)
- DBIc_on(parent, DBIcf_Executed);
- }
if (ima_flags & IMA_KEEP_ERR)
keep_error = TRUE;
if (ima_flags & IMA_KEEP_ERR_SUB
@@ -2990,6 +2984,14 @@
}
}
+ /* set Executed after Callbacks so it's not set if callback elects to skip
the method */
+ if (ima_flags & IMA_EXECUTE) {
+ imp_xxh_t *parent = DBIc_PARENT_COM(imp_xxh);
+ DBIc_on(imp_xxh, DBIcf_Executed);
+ if (parent)
+ DBIc_on(parent, DBIcf_Executed);
+ }
+
/* The "quick_FETCH" logic... */
/* Shortcut for fetching attributes to bypass method call overheads */
if ( (is_FETCH = (*meth_name=='F' && strEQ(meth_name,"FETCH"))) &&
!DBIc_COMPAT(imp_xxh)) {
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 03:10:50 2007
@@ -203,7 +203,7 @@
sub new_response_with_err {
- my ($self, $rv, $eval_error, $h) = @_;
+ my ($self, $rv, $eval_error, $dbh) = @_;
# capture err+errstr etc and merge in $eval_error ($@)
my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
@@ -218,7 +218,9 @@
}
my $flags;
- $flags |= GOf_RESPONSE_EXECUTED if $h && $h->{Executed};
+ # (XXX if we ever add transaction support then we'll need to take extra
+ # steps because the commit/rollback would reset Executed before we get
here)
+ $flags |= GOf_RESPONSE_EXECUTED if $dbh && $dbh->{Executed};
my $response = DBI::Gofer::Response->new({
rv => $rv,
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 03:10:50 2007
@@ -43,6 +43,14 @@
}
+
+sub executed_flag_set {
+ my $flags = shift->flags
+ or return 0;
+ return $flags & GOf_RESPONSE_EXECUTED;
+}
+
+
sub add_err {
my ($self, $err, $errstr, $state, $trace) = @_;
Modified: dbi/trunk/t/70callbacks.t
==============================================================================
--- dbi/trunk/t/70callbacks.t (original)
+++ dbi/trunk/t/70callbacks.t Fri Apr 27 03:10:50 2007
@@ -9,7 +9,7 @@
BEGIN {
plan skip_all => '$h->{Callbacks} attribute not supported for
DBI::PurePerl'
if $DBI::PurePerl && $DBI::PurePerl; # doubled to avoid typo
warning
- plan tests => 49;
+ plan tests => 53;
}
$| = 1;
@@ -120,7 +120,7 @@
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
is eval { $dbh->commit }, undef, 'intercepted commit should return undef';
-like $@, '/DBD::ExampleP::db commit failed: faked commit failure/';
+like $@, '/DBD::\w+::db commit failed: faked commit failure/';
is $DBI::err, 42;
is $DBI::errstr, "faked commit failure";
}
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Fri Apr 27 03:10:50 2007
@@ -156,6 +156,7 @@
is_deeply($rowset, [ [ '1', 'oranges' ], [ '2', 'oranges' ] ]);
ok $dbh->do("UPDATE fruit SET dVal='apples' WHERE dVal='oranges'");
+ ok $dbh->{go_response}->executed_flag_set, 'go_response executed flag
should be true';
ok $sth = $dbh->prepare("SELECT dKey, dVal FROM fruit");
ok $sth->execute;
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Fri Apr 27 03:10:50 2007
@@ -30,28 +30,21 @@
# silence the "DBI_GOFER_RANDOM_FAIL set ..." warning
$SIG{__WARN__} = sub { warn "@_" unless "@_" =~ /^DBI_GOFER_RANDOM_FAIL set/ };
+# --- 100% failure rate
+
$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;
-}
+ok !eval { $dbh_100->do("set foo=1") }, 'do method should 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
$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, {
@@ -64,5 +57,18 @@
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;
+exit 0;
+
+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;
+}
