Author: timbo
Date: Mon Jan 22 04:44:41 2007
New Revision: 8673
Modified:
dbi/trunk/DBI.pm
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/Forward.pm
dbi/trunk/lib/DBI/Forward/Execute.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/06attrs.t
Log:
Much more complete handling of many edge cases.
Now passes t/01basics.t t/02dbidrv.t t/03handle.t t/04mods.t t/05thrclone.t
t/06attrs.t
using DBI_AUTOPROXY.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Jan 22 04:44:41 2007
@@ -584,6 +584,8 @@
$driver = $proxy;
DBI->trace_msg(" DBI_AUTOPROXY:
dbi:$driver($driver_attrib_spec):$dsn\n");
}
+ # avoid recursion if proxy calls DBI->connect itself
+ local $ENV{DBI_AUTOPROXY};
my %attributes; # take a copy we can delete from
if ($old_driver) {
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Mon Jan 22 04:44:41 2007
@@ -329,7 +329,8 @@
sub fetch {
my $sth = shift;
- my $dh = $sth->{dbd_datahandle};
+ my $dh = $sth->{dbd_datahandle}
+ or return $sth->set_err(1, "fetch without successful execute");
my $dir = $sth->{dbd_dir};
my %s;
Modified: dbi/trunk/lib/DBD/Forward.pm
==============================================================================
--- dbi/trunk/lib/DBD/Forward.pm (original)
+++ dbi/trunk/lib/DBD/Forward.pm Mon Jan 22 04:44:41 2007
@@ -32,16 +32,19 @@
Taint TaintIn TaintOut
TraceLevel
Warn
+ dbi_connect_closure
);
our $drh = undef; # holds driver handle once initialised
+ our $methods_already_installed;
sub driver{
return $drh if $drh;
DBI->setup_driver('DBD::Forward');
- DBD::Forward::db->install_method('fwd_dbh_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
+ DBD::Forward::db->install_method('fwd_dbh_method', { O=> 0x0004 }) #
IMA_KEEP_ERR
+ unless $methods_already_installed++;
my($class, $attr) = @_;
$class .= "::dr";
@@ -144,7 +147,9 @@
my $request = $dbh->{fwd_request};
$request->init_request($method, [EMAIL PROTECTED], wantarray);
- my $response = $dbh->{fwd_trans}->execute($request);
+ my $transport = $dbh->{fwd_trans}
+ or return $dbh->set_err(1, "Not connected (no transport)");
+ my $response = $transport->execute($request);
$dbh->{fwd_response} = $response;
@@ -155,13 +160,11 @@
}
# Methods that should be forwarded
- # XXX ping? local or remote - add policy attribute
# XXX get_info? special sub to lazy-cache individual values
for my $method (qw(
do data_sources
table_info column_info primary_key_info foreign_key_info
statistics_info
type_info_all get_info
- ping
)) {
no strict 'refs';
*$method = sub { return shift->fwd_dbh_method($method, undef, @_) }
@@ -178,6 +181,13 @@
# for quote we rely on the default method + type_info_all
# for quote_identifier we rely on the default method + get_info
+ sub ping {
+ my $dbh = shift;
+ # XXX local or remote - add policy attribute
+ return 0 unless $dbh->FETCH('Active');
+ return $dbh->fwd_dbh_method('ping', undef, @_);
+ }
+
sub last_insert_id {
my $dbh = shift;
my $response = $dbh->{fwd_response} or return undef;
@@ -201,9 +211,10 @@
}
return $dbh->SUPER::STORE($attrib => $value)
if $dbh_local_store_attrib{$attrib} # handle locally
- or $attrib =~ m/^[a-z]/ # driver-private
or not $dbh->FETCH('Active'); # not yet connected
+ # XXX or $attrib =~ m/^[a-z]/ # driver-private
+
# ignore values that aren't actually being changed
my $prev = $dbh->FETCH($attrib);
return 1 if !defined $value && !defined $prev
@@ -215,8 +226,9 @@
}
sub disconnect {
- # XXX discard state for dbh and destroy child handles
- shift->STORE(Active => 0);
+ my $dbh = shift;
+ $dbh->{fwd_trans} = undef;
+ $dbh->STORE(Active => 0);
}
sub prepare {
@@ -243,6 +255,26 @@
$imp_data_size = 0;
use strict;
+ my %sth_local_store_attrib = (%DBD::Forward::xxh_local_store_attrib,
NUM_OF_FIELDS => 1);
+
+
+ # sth methods that should always fail, at least for now
+ for my $method (qw(
+ bind_param_inout bind_param_array bind_param_inout_array execute_array
execute_for_fetch
+ )) {
+ no strict 'refs';
+ *$method = sub { return shift->set_err(1, "$method not available") }
+ }
+
+
+ sub bind_param {
+ my ($sth, $param, $value, $attr) = @_;
+ $sth->{ParamValues}{$param} = $value;
+ push @{ $sth->{fwd_method_calls} }, [ 'bind_param', $param, $value,
$attr ];
+ return 1;
+ }
+
+
sub execute {
my($sth, @bind) = @_;
@@ -259,54 +291,58 @@
$sth->{fwd_response} = $response;
$sth->{fwd_method_calls} = [];
- # setup first resultset
- $sth->more_results if $response->sth_resultsets;
+ # setup first resultset - including atributes
+ if ($response->sth_resultsets) {
+ $sth->more_results;
+ }
$sth->set_err($response->err, $response->errstr, $response->state);
+
return $response->rv;
}
- # Methods that should always fail, at least for now
- for my $method (qw(
- bind_param_inout bind_param_array bind_param_inout_array execute_array
execute_for_fetch
- )) {
- no strict 'refs';
- *$method = sub { return shift->set_err(1, "$method not available") }
- }
+ sub more_results {
+ my ($sth) = @_;
+ $sth->finish if $sth->FETCH('Active');
- sub bind_param {
- my ($sth, $param, $value, $attr) = @_;
- $sth->{ParamValues}{$param} = $value;
- push @{ $sth->{fwd_method_calls} }, [ 'bind_param', $param, $value,
$attr ];
- return 1;
+ my $resultset_list = $sth->{fwd_response}->sth_resultsets
+ or return $sth->set_err(1, "No sth_resultsets");
+
+ my $meta = shift @$resultset_list
+ or return undef; # no more result sets
+
+ # pull out the special non-atributes first
+ my ($rowset, $err, $errstr, $state)
+ = delete @{$meta}{qw(rowset err errstr state)};
+
+ # copy meta attributes into attribute cache
+ my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS} || 0;
+ $sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS);
+ $sth->{$_} = $meta->{$_} for keys %$meta;
+
+ if ($NUM_OF_FIELDS > 0) {
+ $sth->{fwd_current_rowset} = $rowset;
+ $sth->{fwd_current_rowset_err} = [ $err, $errstr, $state ] if $err;
+ $sth->STORE(Active => 1) if $rowset;
+ }
+
+ return $sth;
}
+
sub fetchrow_arrayref {
my ($sth) = @_;
- my $resultset = $sth->{fwd_current_resultset}
- or return $sth->set_err(1, "No result set available");
+ my $resultset = $sth->{fwd_current_rowset}
+ or return $sth->set_err( @{ $sth->{fwd_current_rowset_err} } );
return shift @$resultset if @$resultset;
$sth->finish; # no more data so finish
return undef;
}
*fetch = \&fetchrow_arrayref; # alias
- sub more_results {
- my ($sth) = @_;
- $sth->finish if $sth->FETCH('Active');
- my $resultset_list = $sth->{fwd_response}->sth_resultsets
- or return $sth->set_err(1, "No sth_resultsets");
- return undef unless @$resultset_list;
- my $meta = shift @$resultset_list
- or return undef; # no more result sets
- $sth->{fwd_current_resultset} = delete $meta->{rowset}
- or return $sth->set_err(1, "No rowset in meta");
- # copy meta attributes into attribute cache
- $sth->{$_} = $meta->{$_} for keys %$meta;
- return $sth;
- }
+ # XXX fetchall_arrayref - for speed
sub rows {
my $sth = shift;
@@ -314,10 +350,21 @@
return $response->rv;
}
+
sub STORE {
my ($sth, $attrib, $value) = @_;
- DBD::Forward::_note_attrib_store($sth, $attrib, $value);
- return $sth->SUPER::STORE($attrib, $value);
+ return $sth->SUPER::STORE($attrib => $value)
+ if $sth_local_store_attrib{$attrib} # handle locally
+ or $attrib =~ m/^[a-z]/; # driver-private
+
+ # ignore values that aren't actually being changed
+ my $prev = $sth->FETCH($attrib);
+ return 1 if !defined $value && !defined $prev
+ or defined $value && defined $prev && $value eq $prev;
+
+ # sth attributes are set at connect-time - see connect()
+ Carp::carp("Can't alter \$sth->{$attrib}");
+ return $sth->set_err(1, "Can't alter \$sth->{$attrib}");
}
}
Modified: dbi/trunk/lib/DBI/Forward/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Forward/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Forward/Execute.pm Mon Jan 22 04:44:41 2007
@@ -26,8 +26,11 @@
CursorName
);
+# XXX tracing
+
sub _connect {
my $request = shift;
+ local $ENV{DBI_AUTOPROXY};
my $connect_args = $request->connect_args;
my ($dsn, $u, $p, $attr) = @$connect_args;
# XXX need way to limit/purge connect cache over time
@@ -38,10 +41,15 @@
PrintError => 0,
RaiseError => 1,
});
- # $dbh->trace(2);
+ #$dbh->trace(1);
return $dbh;
}
+sub _reset_dbh {
+ my ($dbh) = @_;
+ $dbh->trace(0, \*STDERR);
+}
+
sub execute_request {
my $request = shift;
my $response = eval {
@@ -78,27 +86,38 @@
});
$response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
if $dbh && $rv && $request->dbh_last_insert_id_args;
+ _reset_dbh($dbh);
return $response;
}
sub execute_sth_request {
my $request = shift;
my $dbh;
- my $rv;
- my $resultset_list = eval {
+ my $sth;
+
+ my $rv = eval {
$dbh = _connect($request);
my $meth = $request->dbh_method_name;
my $args = $request->dbh_method_args;
- my $sth = $dbh->$meth(@$args);
+ $sth = $dbh->$meth(@$args);
for my $meth_call (@{ $request->sth_method_calls }) {
my $method = shift @$meth_call;
$sth->$method(@$meth_call);
}
- $rv = $sth->execute();
+ $sth->execute();
+ };
+ my $response = DBI::Forward::Response->new({
+ rv => $rv,
+ err => $DBI::err,
+ errstr => $DBI::errstr,
+ state => $DBI::state,
+ });
+ # even if the eval failed we still want to gather attribute values
+ my $resultset_list = eval {
my $attr_list = $request->sth_result_attr;
$attr_list = [ keys %$attr_list ] if ref $attr_list eq 'HASH';
my $rs_list = [];
@@ -109,13 +128,12 @@
$rs_list;
};
- my $response = DBI::Forward::Response->new({
- rv => $rv,
- err => $DBI::err,
- errstr => $DBI::errstr,
- state => $DBI::state,
- sth_resultsets => $resultset_list,
- });
+ $response->sth_resultsets( $resultset_list );
+
+ # XXX would be nice to be able to support streaming of results
+ # which would reduce memory usage and latency for large results
+
+ _reset_dbh($dbh);
return $response;
}
@@ -126,7 +144,12 @@
for my $attr (@sth_std_attr, @$extra_attr) {
$meta{ $attr } = $sth->{$attr};
}
- $meta{rowset} = $sth->fetchall_arrayref();
+ if ($sth->FETCH('NUM_OF_FIELDS')) { # if a select
+ $meta{rowset} = eval { $sth->fetchall_arrayref() };
+ $meta{err} = $DBI::err;
+ $meta{errstr} = $DBI::errstr;
+ $meta{state} = $DBI::state;
+ }
return \%meta;
}
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Mon Jan 22 04:44:41 2007
@@ -40,6 +40,7 @@
ok(exists $drivers{ExampleP});
ok($drivers{ExampleP}->isa('DBI::dr'));
+my $using_dbd_forward_null = ($ENV{DBI_AUTOPROXY}||'') =~
/dbi:Forward.*transport=null/i;
## ----------------------------------------------------------------------------
# do database handle tests inside do BLOCK to capture scope
@@ -47,6 +48,8 @@
do {
my $dbh = DBI->connect("dbi:$driver:", '', '');
isa_ok($dbh, 'DBI::db');
+
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_forward_null
SKIP: {
skip "Kids and ActiveKids attributes not supported under
DBI::PurePerl", 2 if $DBI::PurePerl;
@@ -136,7 +139,8 @@
}
SKIP: {
- skip "become() not supported under DBI::PurePerl", 23 if $DBI::PurePerl;
+ skip "swap_inner_handle() not supported under DBI::PurePerl", 23 if
$DBI::PurePerl;
+ skip "swap_inner_handle() not testable under DBI_AUTOPROXY", 23 if
$using_dbd_forward_null;
my $sth6 = $dbh->prepare($sql);
$sth6->execute(".");
@@ -193,6 +197,9 @@
};
+if ($using_dbd_forward_null) {
+ $drh->{CachedKids} = {};
+}
# make sure our driver has no more kids after this test
# NOTE:
@@ -200,7 +207,7 @@
SKIP: {
skip "Kids attribute not supported under DBI::PurePerl", 1 if
$DBI::PurePerl;
- cmp_ok($drh->{Kids}, '==', 0, '... our Driver has no Kids after it was
destoryed');
+ cmp_ok($drh->{Kids}, '==', 0, "... our $drh->{Name} driver should have 0
Kids after dbh was destoryed");
}
## ----------------------------------------------------------------------------
@@ -241,6 +248,7 @@
SKIP: {
skip "Kids attribute not supported under DBI::PurePerl", 25 if
$DBI::PurePerl;
+ skip "drh Kids not testable under DBI_AUTOPROXY", 25 if
$using_dbd_forward_null;
foreach my $args (
{},
@@ -261,9 +269,11 @@
SKIP: {
skip "take_imp_data test not supported under DBI::PurePerl", 19 if
$DBI::PurePerl;
+ skip "take_imp_data test not supported under DBI_AUTOPROXY", 19 if
$using_dbd_forward_null;
my $dbh = DBI->connect("dbi:$driver:", '', '');
isa_ok($dbh, "DBI::db");
+ my $drh = $dbh->{Driver}; # (re)get drh here so tests can work
using_dbd_forward_null
cmp_ok($drh->{Kids}, '==', 1, '... our Driver should have 1 Kid(s) here');
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Mon Jan 22 04:44:41 2007
@@ -17,6 +17,8 @@
$|=1;
+my $using_autoproxy = ($ENV{DBI_AUTOPROXY});
+
# Connect to the example driver.
my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
{
@@ -66,7 +68,8 @@
ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for
dbh');
is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute
for dbh');
-is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh');
# fails for Multiplex
+is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh')
# fails for Multiplex
+ unless $using_autoproxy && ok(1);
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute for dbh');
cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for dbh');
@@ -75,7 +78,7 @@
eval {
$dbh->do('select foo from foo')
};
-like($@, qr/^DBD::(ExampleP|Multiplex)::db do failed: Unknown field names:
foo/ , '... catching exception');
+like($@, qr/^DBD::(ExampleP|Multiplex|Forward)::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');
@@ -133,7 +136,8 @@
cmp_ok($drh->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for drh');
is($drh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName
attribute for drh');
-is($drh->{Name}, 'ExampleP', '... checking Name attribute for
drh');
+is($drh->{Name}, 'ExampleP', '... checking Name attribute for drh')
+ unless $using_autoproxy && ok(1);
## ----------------------------------------------------------------------------
# Test the statement handle attributes.
@@ -151,10 +155,10 @@
$sth->execute("foo")
};
# we don't check actual opendir error msg because of locale differences
-like($@, qr/^DBD::(ExampleP|Multiplex)::st execute failed: opendir\(foo\): /i,
'... checking exception');
+like($@, qr/^DBD::(ExampleP|Multiplex|Forward)::st execute failed:
.*opendir\(foo\): /msi, '... checking exception');
# Test all of the statement handle attributes.
-like($sth->errstr, qr/^opendir\(foo\): /, '... checking $sth->errstr');
+like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
is($sth->state, 'S1000', '... checking $sth->state');
ok($sth->{Executed}, '... checking Executed attribute for sth'); # even
though it failed
ok($dbh->{Executed}, '... checking Exceuted attribute for dbh'); # due
to $sth->prepare, even though it failed
