Author: timbo
Date: Tue May 1 04:03:38 2007
New Revision: 9478
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/lib/DBI/Util/_accessor.pm
dbi/trunk/t/06attrs.t
dbi/trunk/t/09trace.t
dbi/trunk/t/10examp.t
dbi/trunk/t/86gofer_fail.t
Log:
Added ReadOnly attribute.
Consider ReadOnly attribute in controling gofer retries.
Added go_retry_hook to allow application control of retries.
Add tests for ReadOnly.
Rejig trace tests.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue May 1 04:03:38 2007
@@ -22,7 +22,7 @@
only fetch one result set - handy for Sybase/MSSQL users
will accept streamed resultsets
Pedantic policy should force a fresh connect each time - add new policy item
-Add attr-passthru to prepare()? ie for gofer cache control
+Add attr-passthru to prepare()? ie for gofer cache control & ReadOnly
Terminology for client and server ends
Document user/passwd issues at the various levels of the gofer stack
Policy's from pod
@@ -65,6 +65,7 @@
Callbacks can now elect to provide a value to be returned, in which case
the method won't be called. A callback for "*" is applied to all methods
that don't have their own callback.
+ Added $h->{ReadOnly} attribute.
Added support for DBI Profile Path to contain refs to scalars
which will be de-ref'd for each profile sample.
Added dbilogstrip utility to edit DBI logs for diff'ing (gets installed)
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Tue May 1 04:03:38 2007
@@ -636,6 +636,7 @@
# been called yet and so the dbh errstr would not have been copied
# up to the drh errstr. Certainly true for connect_cached!
my $errstr = $DBI::errstr;
+ # Getting '(no error string)' here is a symptom of a ref loop
$errstr = '(no error string)' if !defined $errstr;
my $msg = "$class connect('$dsn','$user',...) failed: $errstr";
DBI->trace_msg(" $msg\n");
@@ -3804,6 +3805,25 @@
The C<Profile> attribute was added in DBI 1.24.
+=item C<ReadOnly> (boolean, inherited)
+
+An application can set the C<ReadOnly> attribute of a handle to a true value to
+indicate that it will not be attempting to make any changes (insert, delete,
+update etc) using that handle or any children of it.
+
+If the driver can make the handle truly read-only (by issuing a statement like
+"C<set transaction read only>" as needed, for example) then it should.
+Otherwise the attribute is simply advisory.
+
+A driver can set the C<ReadOnly> attribute itself to indicate that the data it
+is connected to cannot be changed for some reason.
+
+Library modules and proxy drivers can use the attribute to influence their
behavior.
+For example, the DBD::Gofer driver considers the C<ReadOnly> attribute when
+making a decison about whether to retry an operation that failed.
+
+The attribute should be set to 1 or 0. (Other values are reserved.)
+
=item C<private_your_module_name_*>
The DBI provides a way to store extra information in a DBI handle as
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Tue May 1 04:03:38 2007
@@ -1091,9 +1091,8 @@
if (parent) {
dbih_setup_attrib(aTHX_ h,imp,"HandleSetErr",parent,0,1);
dbih_setup_attrib(aTHX_ h,imp,"HandleError",parent,0,1);
- if (DBIc_has(parent_imp,DBIcf_Profile)) {
- dbih_setup_attrib(aTHX_ h,imp,"Profile",parent,0,1);
- }
+ dbih_setup_attrib(aTHX_ h,imp,"ReadOnly",parent,0,1);
+ dbih_setup_attrib(aTHX_ h,imp,"Profile",parent,0,1);
DBIc_LongReadLen(imp) = DBIc_LongReadLen(parent_imp);
#ifdef sv_rvweaken
if (1) {
@@ -1735,6 +1734,7 @@
/* these are here due to clone() needing to set attribs through a public
api */
else if (htype<=DBIt_DB && (strEQ(key, "Name")
|| strEQ(key,"ImplementorClass")
+ || strEQ(key,"ReadOnly")
|| strEQ(key,"Statement")
|| strEQ(key,"Username")
/* these are here for backwards histerical raisons */
@@ -2069,6 +2069,7 @@
|| (*key=='P' && strEQ(key, "ParamArrays"))
|| (*key=='P' && strEQ(key, "ParamValues"))
|| (*key=='P' && strEQ(key, "Profile"))
+ || (*key=='R' && strEQ(key, "ReadOnly"))
|| (*key=='C' && strEQ(key, "CursorName"))
|| (*key=='C' && strEQ(key, "Callbacks"))
|| (*key=='U' && strEQ(key, "Username"))
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Tue May 1 04:03:38 2007
@@ -248,10 +248,10 @@
sub go_dbh_method {
my $dbh = shift;
my $meta = shift;
- # $method and @args left in @_
+ # @_ now contains ($method_name, @args)
my $request = $dbh->{go_request};
- $request->init_request([ wantarray, @_ ]);
+ $request->init_request([ wantarray, @_ ], $dbh);
++$dbh->{go_request_count};
my $go_policy = $dbh->{go_policy};
@@ -567,7 +567,7 @@
++$dbh->{go_request_count};
my $request = $sth->{go_request};
- $request->init_request($sth->{go_prepare_call});
+ $request->init_request($sth->{go_prepare_call}, $sth);
$request->sth_method_calls(delete $sth->{go_method_calls})
if $sth->{go_method_calls};
$request->sth_result_attr({}); # (currently) also indicates this is an
sth request
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 1 04:03:38 2007
@@ -19,8 +19,13 @@
go_dsn
go_url
go_timeout
+ go_retry_hook
go_retry_limit
));
+__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
+ meta
+));
+
sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 }
@@ -66,7 +71,7 @@
my $response;
do {
$response = $transmit_sub->();
- } while ( $response && $self->response_needs_retransmit($response,
$request) );
+ } while ( $response && $self->response_needs_retransmit($request,
$response) );
return $response;
}
@@ -96,42 +101,56 @@
my $response;
do {
$response = $receive_sub->();
- if ($self->response_needs_retransmit($response, $request)) {
+ if ($self->response_needs_retransmit($request, $response)) {
$response = $self->_transmit_request_with_retries($request,
$retransmit_sub);
$response ||= $receive_sub->();
}
- } while ( $self->response_needs_retransmit($response, $request) );
+ } while ( $self->response_needs_retransmit($request, $response) );
return $response;
}
sub response_needs_retransmit {
- my ($self, $response, $request) = @_;
+ my ($self, $request, $response) = @_;
my $err = $response->err
- or return 0; # nothing wen't wrong
+ or return 0; # nothing went wrong
my $retry;
- my $errstr = $response->errstr || '';
- my $idempotent = 0; # XXX set to 1 for idempotent requests, ie selects
+ # give the user a chance to express a preference (or undef for default)
+ if (my $go_retry_hook = $self->go_retry_hook) {
+ $retry = $go_retry_hook->($request, $response, $self);
+ $self->trace_msg(sprintf "response_needs_retransmit: go_retry_hook
returned %s\n",
+ (defined $retry) ? $retry : 'undef');
+ }
- $retry = 1 if $errstr =~ m/fake error induced by DBI_GOFER_RANDOM_FAIL/;
+ if (not defined $retry) {
+ my $errstr = $response->errstr || '';
+ $retry = 1 if $errstr =~ m/fake error induced by
DBI_GOFER_RANDOM_FAIL/;
+ }
- if (!$retry) {
+ if (not defined $retry) {
+ my $idempotent = $request->is_idempotent; # i.e. is SELECT or ReadOnly
was set
+ $retry = 1 if $idempotent;
+ }
+
+ if (!$retry) { # false or undef
$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");
+ if (($meta->{retry_count}||=0) >= $retry_limit) {
+ $self->trace_msg("response_needs_retransmit: $meta->{retry_count} is
too many retries\n");
return 0;
}
- $self->trace_msg("response_needs_retransmit: retry $retry_count\n");
+ ++$meta->{retry_count}; # count for this request
+ ++$self->meta->{request_retry_count}; # cumulative transport stats
+ $self->trace_msg("response_needs_retransmit: retry
$meta->{retry_count}\n");
return 1;
}
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 1 04:03:38 2007
@@ -338,9 +338,9 @@
$h = tied(%$h) || $h; # switch to inner handle
my $attr_names = $h->{private_gofer_std_attr_names};
return $attr_names if $attr_names;
- # add ChopBlanks LongReadLen LongTruncOk because drivers may have
different defaults
- # plus Name so the client gets the real Name of the connection
- my @attr_names = qw(ChopBlanks LongReadLen LongTruncOk Name);
+ # add some extra because drivers may have different defaults
+ # add Name so the client gets the real Name of the connection
+ my @attr_names = qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
if (my $pai = $h->private_attribute_info) {
push @attr_names, keys %$pai;
}
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Tue May 1 04:03:38 2007
@@ -15,9 +15,15 @@
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+use constant GOf_REQUEST_IDEMPOTENT => 0x0001;
+use constant GOf_REQUEST_READONLY => 0x0002;
+
+our @EXPORT = qw(GOf_REQUEST_IDEMPOTENT GOf_REQUEST_READONLY);
+
__PACKAGE__->mk_accessors(qw(
version
+ flags
dbh_connect_call
dbh_method_call
dbh_attributes
@@ -25,7 +31,7 @@
sth_method_calls
sth_result_attr
));
-__PACKAGE__->mk_accessors_with(make_accessor_autoviv_hashref => qw(
+__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
meta
));
@@ -38,21 +44,58 @@
sub reset {
- my $self = shift;
+ my ($self, $flags) = @_;
# remove everything except connect and version
- %$self = ( version => $self->{version}, dbh_connect_call =>
$self->{dbh_connect_call} );
+ %$self = (
+ version => $self->{version},
+ dbh_connect_call => $self->{dbh_connect_call},
+ );
+ $self->{flags} = $flags if $flags;
+}
+
+
+sub init_request {
+ my ($self, $method_and_args, $dbh) = @_;
+ $self->reset( $dbh->{ReadOnly} ? GOf_REQUEST_READONLY : 0 );
+ $self->dbh_method_call($method_and_args);
}
+
sub is_sth_request {
return shift->{sth_result_attr};
}
-sub init_request {
- my ($self, $method_and_args) = @_;
- $self->reset;
- $self->dbh_method_call($method_and_args);
+
+sub statements {
+ my $self = shift;
+ my @statements;
+ my $statement_method_regex = qr/^(?:do|prepare)$/;
+ if (my $dbh_method_call = $self->dbh_method_call) {
+ my (undef, $method, $arg1) = @$dbh_method_call;
+ push @statements, $arg1 if $method =~ $statement_method_regex;
+ }
+ return @statements;
+}
+
+
+sub is_idempotent {
+ my $self = shift;
+
+ if (my $flags = $self->flags) {
+ return 1 if $flags & (GOf_REQUEST_IDEMPOTENT|GOf_REQUEST_READONLY);
+ }
+
+ # else check if all statements are select statement
+ my @statements = $self->statements;
+ # XXX this is very minimal for now, doesn't even allow comments before the
select
+ # (and can't ever work for "exec stored_procedure_name" kinds of
statements)
+ # XXX it also doesn't deal with multiple statements: prepare("select foo;
update bar")
+ return 1 if @statements == grep { m/^ \s* SELECT \b/xmsi } @statements;
+
+ return 0;
}
+
sub summary_as_text {
my $self = shift;
my ($context) = @_;
@@ -74,6 +117,10 @@
}
push @s, sprintf "dbh= $method(%s, %s)", neat_list([$dsn, $user, $pass]),
$tmp;
+ if (my $flags = $self->flags) {
+ push @s, sprintf "flags: 0x%x", $flags;
+ }
+
if (my $dbh_attr = $self->dbh_attributes) {
push @s, sprintf "dbh->FETCH: %s", @$dbh_attr
if @$dbh_attr;
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Tue May 1 04:03:38 2007
@@ -33,7 +33,7 @@
sth_resultsets
warnings
));
-__PACKAGE__->mk_accessors_with(make_accessor_autoviv_hashref => qw(
+__PACKAGE__->mk_accessors_using(make_accessor_autoviv_hashref => qw(
meta
));
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Tue May 1 04:03:38 2007
@@ -177,6 +177,7 @@
ParamValues
Profile
Provider
+ ReadOnly
RootClass
RowCacheSize
RowsInCache
@@ -483,7 +484,7 @@
if ($parent) {
foreach (qw(
RaiseError PrintError PrintWarn HandleError HandleSetErr
- Warn LongTruncOk ChopBlanks AutoCommit
+ Warn LongTruncOk ChopBlanks AutoCommit ReadOnly
ShowErrorStatement FetchHashKeyName LongReadLen CompatMode
)) {
$h_inner->{$_} = $parent->{$_}
Modified: dbi/trunk/lib/DBI/Util/_accessor.pm
==============================================================================
--- dbi/trunk/lib/DBI/Util/_accessor.pm (original)
+++ dbi/trunk/lib/DBI/Util/_accessor.pm Tue May 1 04:03:38 2007
@@ -3,7 +3,7 @@
use Carp;
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/);
-# based (ever more loosly) on Class::Accessor::Fast
+# inspired by Class::Accessor::Fast
sub new {
my($proto, $fields) = @_;
@@ -19,10 +19,10 @@
sub mk_accessors {
my($self, @fields) = @_;
- $self->mk_accessors_with('make_accessor', @fields);
+ $self->mk_accessors_using('make_accessor', @fields);
}
-sub mk_accessors_with {
+sub mk_accessors_using {
my($self, $maker, @fields) = @_;
my $class = ref $self || $self;
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Tue May 1 04:03:38 2007
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 137;
+use Test::More tests => 142;
## ----------------------------------------------------------------------------
## 06attrs.t - ...
@@ -18,13 +18,12 @@
$|=1;
my $using_autoproxy = ($ENV{DBI_AUTOPROXY});
+my $dsn = 'dbi:ExampleP:dummy';
# Connect to the example driver.
-my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
- {
- PrintError => 0,
- RaiseError => 1,
- });
+my $dbh = DBI->connect($dsn, '', '', {
+ PrintError => 0, RaiseError => 1,
+});
isa_ok( $dbh, 'DBI::db' );
@@ -66,6 +65,7 @@
ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh');
ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh');
ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for
dbh');
+ok(!defined $dbh->{ReadOnly}, '... checking ReadOnly attribute for dbh');
is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute
for dbh');
is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh')
# fails for Multiplex
@@ -78,7 +78,7 @@
eval {
$dbh->do('select foo from foo')
};
-like($@, qr/^DBD::(ExampleP|Multiplex|Gofer)::db do failed: Unknown field
names: foo/ , '... catching exception');
+like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching
exception');
ok(defined $dbh->err, '... $dbh->err is undefined');
like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking
$dbh->errstr');
@@ -131,6 +131,7 @@
is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh');
ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
ok(!defined $drh->{Profile}, '... checking Profile attribute for drh');
+ok(!defined $drh->{ReadOnly}, '... checking ReadOnly attribute for drh');
cmp_ok($drh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute for drh');
cmp_ok($drh->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for drh');
@@ -155,7 +156,7 @@
$sth->execute("foo")
};
# we don't check actual opendir error msg because of locale differences
-like($@, qr/^DBD::(ExampleP|Multiplex|Gofer)::st execute failed:
.*opendir\(foo\): /msi, '... checking exception');
+like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '...
checking exception');
# Test all of the statement handle attributes.
like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
@@ -199,6 +200,7 @@
ok(!defined $sth->{CachedKids}, '... checking CachedKids attribute for sth');
ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth');
ok(!defined $sth->{Profile}, '... checking Profile attribute for sth');
+ok(!defined $sth->{ReadOnly}, '... checking ReadOnly attribute for sth');
cmp_ok($sth->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute for sth');
cmp_ok($sth->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for sth');
@@ -274,5 +276,26 @@
# $h->{TraceLevel} tests are in t/09trace.t
+print "Checking inheritance\n";
+
+SKIP: {
+ skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if
$ENV{DBI_AUTOPROXY};
+
+sub check_inherited {
+ my ($drh, $attr, $value, $skip_sth) = @_;
+ local $drh->{$attr} = $value;
+ local $drh->{PrintError} = 1;
+ my $dbh = $drh->connect("dummy");
+ is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from
drh";
+ unless ($skip_sth) {
+ my $sth = $dbh->prepare("select name from .");
+ is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited
from dbh";
+ }
+}
+
+check_inherited($drh, "ReadOnly", 1, 0);
+
+}
+
1;
# end
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Tue May 1 04:03:38 2007
@@ -3,8 +3,7 @@
use strict;
-# 66 tests originally
-use Test::More tests => 66;
+use Test::More tests => 67;
## ----------------------------------------------------------------------------
## 09trace.t
@@ -19,15 +18,33 @@
$|=1;
-## ----------------------------------------------------------------------------
-# Connect to the example driver.
-my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
- { PrintError => 0,
- RaiseError => 1,
- PrintWarn => 1,
- });
-isa_ok( $dbh, 'DBI::db' );
+my $trace_file = "dbitrace.log";
+
+if (-e $trace_file) {
+ 1 while unlink $trace_file;
+ die "Can't unlink existing $trace_file: $!" if -e $trace_file;
+}
+
+my $orig_trace_level = DBI->trace;
+DBI->trace(3, $trace_file); # enable trace before first driver load
+
+my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
+die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
+
+isa_ok($dbh, 'DBI::db');
+
+$dbh->dump_handle("dump_handle test, write to log file", 2);
+
+DBI->trace(0, undef); # turn off and restore to STDERR
+
+SKIP: {
+ skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
+ ok( -s $trace_file, "trace file size = " . -s $trace_file);
+}
+
+DBI->trace($orig_trace_level); # no way to restore previous outfile XXX
+
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
@@ -37,8 +54,6 @@
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute');
-my $trace_file = "dbitrace.log";
-
1 while unlink $trace_file;
$dbh->trace(0, $trace_file);
@@ -108,6 +123,8 @@
is $warn, 2;
}
+$dbh->dump_handle("dump_handle test, write to log file", 2);
+
$dbh->trace(0);
ok !$dbh->{TraceLevel};
$dbh->trace(undef, "STDERR"); # close $trace_file
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Tue May 1 04:03:38 2007
@@ -12,59 +12,18 @@
my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';
-use Test::More tests => 209;
+use Test::More tests => 205;
# "globals"
my ($r, $dbh);
-## testing tracing to file
-sub trace_to_file {
-
- my $trace_file = "dbitrace.log";
-
- if (-e $trace_file) {
- 1 while unlink $trace_file;
- die "Can't unlink existing $trace_file: $!" if -e $trace_file;
- }
-
- my $orig_trace_level = DBI->trace;
- DBI->trace(3, $trace_file); # enable trace before first
driver load
-
- $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
- die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
-
- isa_ok($dbh, 'DBI::db');
-
- $dbh->dump_handle("dump_handle test, write to log file", 2);
-
- DBI->trace(0, undef); # turn off and restore to STDERR
-
- SKIP: {
- skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
- ok( -s $trace_file, "trace file size = " . -s $trace_file);
- }
-
- my $unlinked = unlink( $trace_file );
- ok( $unlinked, "Remove trace file $trace_file ($!)" );
- ok( !-e $trace_file, "Trace file actually gone" );
-
- DBI->trace($orig_trace_level); # no way to restore previous outfile XXX
-}
-
-trace_to_file();
-
-# internal hack to assist debugging using DBI_TRACE env var. See DBI.pm.
-DBI->trace(@DBI::dbi_debug) if @DBI::dbi_debug;
-
-my $dbh2;
-eval {
- $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1,
AutoCommit => 1 });
-};
+ok !eval {
+ $dbh = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1,
AutoCommit => 1 });
+}, 'connect should fail';
like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an
exception here');
-ok(!$dbh2, '... $dbh2 should not be defined');
+ok(!$dbh, '... $dbh2 should not be defined');
-$dbh2 = DBI->connect('dbi:ExampleP:', '', '');
-ok($dbh ne $dbh2);
+$dbh = DBI->connect('dbi:ExampleP:', '', '');
sub check_connect_cached {
# connect_cached
@@ -181,7 +140,6 @@
my($col0, $col1, $col2, $col3, $rows);
my(@row_a, @row_b);
-#$csr_a->trace(5);
ok($csr_a->bind_columns(undef, \($col0, $col1, $col2)) );
ok($csr_a->execute( $dir ), $DBI::errstr);
@@ -192,7 +150,6 @@
is($row_a[0], $col0);
is($row_a[1], $col1);
is($row_a[2], $col2);
-#$csr_a->trace(0);
ok( ! $csr_a->bind_columns(undef, \($col0, $col1)) );
like $csr_a->errstr, '/bind_columns called with 2 values but 3 are needed/',
'errstr should contain error message';
@@ -259,20 +216,17 @@
print "fetchall_arrayref hash slice\n";
ok($csr_b->execute());
-#$csr_b->trace(9);
$r = $csr_b->fetchall_arrayref({ SizE=>1, nAMe=>1});
ok($r && @$r);
ok($r->[0]->{SizE} == $row_a[1]);
ok($r->[0]->{nAMe} eq $row_a[2]);
-#$csr_b->trace(4);
print "fetchall_arrayref hash\n";
ok($csr_b->execute());
$r = $csr_b->fetchall_arrayref({});
ok($r);
ok(keys %{$r->[0]} == 3);
ok("@{$r->[0]}{qw(MODE SIZE NAME)}" eq "@row_a", "'@{$r->[0]}{qw(MODE SIZE
NAME)}' ne '@row_a'");
-#$csr_b->trace(0);
# use Data::Dumper; warn Dumper([EMAIL PROTECTED], $r]);
@@ -280,7 +234,6 @@
ok($rows > 0, "row count $rows");
ok($rows == @$r, "$rows vs "[EMAIL PROTECTED]);
ok($rows == $DBI::rows, "$rows vs $DBI::rows");
-#$csr_b->trace(0);
# ---
@@ -447,8 +400,6 @@
ok(!$@, $@);
ok(!defined($r), $r);
-#$dbh->trace(4);
-
print "HandleError -> 2 -> return (modified)42\n";
$HandleErrorReturn = 2;
$r = eval { $csr_c = $dbh->prepare($error_sql); };
@@ -458,8 +409,6 @@
$dbh->{HandleError} = undef;
ok(!$dbh->{HandleError});
-#$dbh->trace(0); die;
-
{
# dump_results;
my $sth = $dbh->prepare($std_sql);
@@ -505,7 +454,6 @@
}
print "Local $dir subdirs: @{[ keys %dirs ]}\n";
closedir(DIR);
-#$dbh->trace(9);
my $sth = $dbh->table_info($dir, undef, "%", "TABLE");
ok($sth);
%unexpected = %dirs;
@@ -522,8 +470,6 @@
ok(keys %missing == 0)
or print "Missing directories: ", join(",", keys %missing), "\n";
-#$dbh->trace(0); die 1;
-
print "tables\n";
my @tables_expected = (
q{"schema"."table"},
Modified: dbi/trunk/t/86gofer_fail.t
==============================================================================
--- dbi/trunk/t/86gofer_fail.t (original)
+++ dbi/trunk/t/86gofer_fail.t Tue May 1 04:03:38 2007
@@ -8,11 +8,12 @@
use DBI;
use Data::Dumper;
use Test::More;
+sub between_ok;
# here we test the DBI_GOFER_RANDOM_FAIL mechanism
# and how gofer deals with failures
-plan skip_all => "DBI_GOFER_RANDOM_FAIL not supported with PurePerl" if
$DBI::PurePerl;
+plan skip_all => "requires Callbacks which are not supported with PurePerl" if
$DBI::PurePerl;
if (my $ap = $ENV{DBI_AUTOPROXY}) { # limit the insanity
plan skip_all => "Gofer DBI_AUTOPROXY" if $ap =~ /^dbi:Gofer/i;
@@ -61,8 +62,7 @@
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";
-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%';
+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)
@@ -79,13 +79,46 @@
$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} = "2,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", {
+ go_retry_hook => sub { return ($_[0]->is_idempotent) ? 1 : 0 },
+ ReadOnly => 1,
+} );
+between_ok precentage_exceptions(100, sub { $dbh_50r1ro->do("set foo=1") }),
+ 15, 35, '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';
+
+# 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") }),
+ 35, 65, 'should fail ~50%, ie no retries';
+ok !$dbh_50r1rw->{go_transport}->meta->{request_retry_count},
+ 'transport request_retry_count should be zero or undef';
+
+
+
exit 0;
+sub between_ok {
+ my ($got, $min, $max, $label) = @_;
+ local $Test::Builder::Level = 2;
+ cmp_ok $got, '>=', $min, "$label (got $got)";
+ cmp_ok $got, '<=', $max, "$label (got $got)";
+}
+
sub dbi_connect {
- my ($gdsn) = @_;
+ my ($gdsn, $attr) = @_;
return DBI->connect("dbi:Gofer:transport=null;$gdsn;dsn=dbi:ExampleP:", 0,
0, {
- RaiseError => 1, PrintError => 0,
+ RaiseError => 1, PrintError => 0, ($attr) ? %$attr : ()
});
}
