Author: timbo
Date: Wed Jan 24 08:58:18 2007
New Revision: 8693
Modified:
dbi/trunk/DBI.xs
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/Forward.pm
dbi/trunk/lib/DBD/Forward/Transport/Base.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/lib/DBI/Forward/Execute.pm
dbi/trunk/t/03handle.t
dbi/trunk/t/10examp.t
Log:
DBD::Forward now correctly tables dbh methods that return sth (like table_info).
Test suite now has autogenerated wrappers for DBD::Forward and
DBD::Forward+PurePerl.
All tests pass! (Files=146, Tests=6051)
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Wed Jan 24 08:58:18 2007
@@ -1714,7 +1714,7 @@
PerlIO_printf(DBILOGFP,"Warning: changing NUM_OF_FIELDS (from %d
to %d) after row buffer already allocated",
SvIV(valuesv), DBIc_NUM_FIELDS(imp_sth));
}
- DBIc_NUM_FIELDS(imp_sth) = SvIV(valuesv);
+ DBIc_NUM_FIELDS(imp_sth) = (SvOK(valuesv)) ? SvIV(valuesv) : -1;
cacheit = 1;
}
else if (htype==DBIt_ST && strEQ(key, "NUM_OF_PARAMS")) {
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Wed Jan 24 08:58:18 2007
@@ -75,6 +75,7 @@
t/43prof_env.t
t/50dbm.t
t/60preparse.t
+t/65transact.t
t/70callbacks.t
t/72childhandles.t
t/80proxy.t
Modified: dbi/trunk/lib/DBD/Forward.pm
==============================================================================
--- dbi/trunk/lib/DBD/Forward.pm (original)
+++ dbi/trunk/lib/DBD/Forward.pm Wed Jan 24 08:58:18 2007
@@ -48,8 +48,10 @@
DBI->setup_driver('DBD::Forward');
- DBD::Forward::db->install_method('fwd_dbh_method', { O=> 0x0004 }) #
IMA_KEEP_ERR
- unless $methods_already_installed++;
+ unless ($methods_already_installed++) {
+ DBD::Forward::db->install_method('fwd_dbh_method', { O=> 0x0004
}); # IMA_KEEP_ERR
+ DBD::Forward::st->install_method('fwd_sth_method', { O=> 0x0004
}); # IMA_KEEP_ERR
+ }
my($class, $attr) = @_;
$class .= "::dr";
@@ -125,6 +127,7 @@
'USER' => $user,
fwd_trans => $fwd_trans,
fwd_request => $fwd_request,
+ fwd_policy => undef, # XXX
});
$dbh->STORE(Active => 0); # mark as inactive temporarily for STORE
@@ -138,6 +141,7 @@
# test the connection XXX control via a policy later
$dbh->fwd_dbh_method('ping', undef)
or return;
+ # unless $policy->skip_connect_ping($attr, $dsn, $user, $auth,
$attr);
$dbh->STORE(Active => 1);
@@ -157,7 +161,6 @@
sub fwd_dbh_method {
my ($dbh, $method, $meta, @args) = @_;
- $dbh->trace_msg(" fwd_dbh_method($dbh, $method, @args)\n");
my $request = $dbh->{fwd_request};
$request->init_request($method, [EMAIL PROTECTED], wantarray);
@@ -168,12 +171,22 @@
or return $dbh->set_err(1, "transmit_request failed: $@");
my $response = $transport->receive_response;
+ my $rv = $response->rv;
$dbh->{fwd_response} = $response;
+ if (my $resultset_list = $response->sth_resultsets) {
+ # setup an sth but don't execute/forward it
+ my $sth = $dbh->prepare(undef, { fwd_skip_early_prepare => 1 }); #
XXX
+ # set the sth response to our dbh response
+ (tied %$sth)->{fwd_response} = $response;
+ # setup the set with the results in our response
+ $sth->more_results;
+ $rv = [ $sth ];
+ }
+
$dbh->set_err($response->err, $response->errstr, $response->state);
- #$dbh->rows($response->rows); # can't, and not needed?
- my $rv = $response->rv;
+
return (wantarray) ? @$rv : $rv->[0];
}
@@ -195,7 +208,7 @@
begin_work commit rollback
)) {
no strict 'refs';
- *$method = sub { return shift->set_err(1, "$method not available") }
+ *$method = sub { return shift->set_err(1, "$method not available with
DBD::Forward") }
}
# for quote we rely on the default method + type_info_all
@@ -211,7 +224,7 @@
sub ping {
my $dbh = shift;
# XXX local or remote - add policy attribute
- return 0 unless $dbh->FETCH('Active');
+ return 0 unless $dbh->SUPER::FETCH('Active');
return $dbh->fwd_dbh_method('ping', undef, @_);
}
@@ -224,7 +237,6 @@
sub FETCH {
my ($dbh, $attrib) = @_;
- return 1 if $attrib eq 'AutoCommit'; # AutoCommit needs special handling
# forward driver-private attributes
if ($attrib =~ m/^[a-z]/) { # XXX policy? precache on connect?
@@ -265,21 +277,34 @@
$dbh->STORE(Active => 0);
}
+ # XXX + prepare_cached ?
+ #
sub prepare {
my ($dbh, $statement, $attr)= @_;
return $dbh->set_err(1, "Can't prepare when disconnected")
unless $dbh->FETCH('Active');
- my ($outer, $sth) = DBI::_new_sth($dbh, {
+ my $policy = $attr->{fwd_policy} || $dbh->{fwd_policy};
+
+ my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
Statement => $statement,
- fwd_prepare_args => [ $statement, $attr ],
+ fwd_prepare_call => [ 'prepare', [ $statement, $attr ] ],
fwd_method_calls => [],
fwd_request => $dbh->{fwd_request},
fwd_trans => $dbh->{fwd_trans},
+ fwd_policy => $policy,
});
- $outer;
+ #my $p_sep = $policy->skip_early_prepare($attr, $dbh, $statement,
$attr, $sth);
+ my $p_sep = 0;
+
+ $p_sep = 1 if not defined $statement; # XXX hack, see fwd_dbh_method
+ if (not $p_sep) {
+ $sth->fwd_sth_method() or return undef;
+ }
+
+ return $sth;
}
}
@@ -291,51 +316,38 @@
my %sth_local_store_attrib = (%DBD::Forward::xxh_local_store_attrib,
NUM_OF_FIELDS => 1);
+ sub fwd_sth_method {
+ my ($sth) = @_;
- # 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) = @_;
-
- # XXX validate that @bind==NUM_OFPARAM
- $sth->bind_param($_, $bind[$_-1]) for ([EMAIL PROTECTED]);
+ if (my $ParamValues = $sth->{ParamValues}) {
+ my $ParamAttr = $sth->{ParamAttr};
+ while ( my ($p, $v) = each %$ParamValues) {
+ # unshift to put binds before execute call
+ unshift @{ $sth->{fwd_method_calls} },
+ [ 'bind_param', $p, $v, $ParamAttr->{$p} ];
+ }
+ }
my $request = $sth->{fwd_request};
- $request->init_request('prepare', $sth->{fwd_prepare_args}, undef);
+ $request->init_request(@{$sth->{fwd_prepare_call}}, undef);
$request->sth_method_calls($sth->{fwd_method_calls});
$request->sth_result_attr({});
my $transport = $sth->{fwd_trans}
or return $sth->set_err(1, "Not connected (no transport)");
-
eval { $transport->transmit_request($request) }
or return $sth->set_err(1, "transmit_request failed: $@");
-
my $response = $transport->receive_response;
-
$sth->{fwd_response} = $response;
- $sth->{fwd_method_calls} = [];
+ delete $sth->{fwd_method_calls};
- # setup first resultset - including atributes
if ($response->sth_resultsets) {
+ # setup first resultset - including atributes
$sth->more_results;
}
-
+ else {
+ $sth->{fwd_rows} = $response->rv;
+ }
# set error/warn/info (after more_results as that'll clear err)
$sth->set_err($response->err, $response->errstr, $response->state);
@@ -343,6 +355,31 @@
}
+ # 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 with
DBD::Forward, yet (patches welcome)") }
+ }
+
+
+ sub bind_param {
+ my ($sth, $param, $value, $attr) = @_;
+ $sth->{ParamValues}{$param} = $value;
+ $sth->{ParamAttr}{$param} = $attr;
+ return 1;
+ }
+
+
+ sub execute {
+ my $sth = shift;
+ $sth->bind_param($_, $_[$_-1]) for ([EMAIL PROTECTED]);
+ push @{ $sth->{fwd_method_calls} }, [ 'execute' ];
+ return $sth->fwd_sth_method;
+ }
+
+
sub more_results {
my ($sth) = @_;
@@ -359,11 +396,12 @@
= delete @{$meta}{qw(rowset err errstr state)};
# copy meta attributes into attribute cache
- my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS} || 0;
+ my $NUM_OF_FIELDS = delete $meta->{NUM_OF_FIELDS};
$sth->STORE('NUM_OF_FIELDS', $NUM_OF_FIELDS);
$sth->{$_} = $meta->{$_} for keys %$meta;
- if ($NUM_OF_FIELDS > 0) {
+ if (($NUM_OF_FIELDS||0) > 0) {
+ $sth->{fwd_rows} = ($rowset) ? @$rowset : -1;
$sth->{fwd_current_rowset} = $rowset;
$sth->{fwd_current_rowset_err} = [ $err, $errstr, $state ]
if defined $err;
@@ -384,18 +422,21 @@
}
*fetch = \&fetchrow_arrayref; # alias
+
sub fetchall_arrayref {
- my ($sth) = @_;
+ my ($sth, $slice, $max_rows) = @_;
+ my $mode = ref($slice) || 'ARRAY';
+ return $sth->SUPER::fetchall_arrayref($slice, $max_rows)
+ if ref($slice) or defined $max_rows;
my $resultset = $sth->{fwd_current_rowset}
or return $sth->set_err( @{ $sth->{fwd_current_rowset_err} } );
$sth->finish; # no more data so finish
return $resultset;
}
+
sub rows {
- my $sth = shift;
- my $response = $sth->{fwd_response} or return -1;
- return $response->rv;
+ return shift->{fwd_rows};
}
@@ -405,12 +446,8 @@
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()
+ # XXX could perhaps do
+ # XXX? push @{ $sth->{fwd_method_calls} }, [ 'STORE', $attrib, $value
];
Carp::carp("Can't alter \$sth->{$attrib}");
return $sth->set_err(1, "Can't alter \$sth->{$attrib}");
}
Modified: dbi/trunk/lib/DBD/Forward/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Forward/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBD/Forward/Transport/Base.pm Wed Jan 24 08:58:18 2007
@@ -18,11 +18,13 @@
sub freeze_data {
my ($self, $data) = @_;
$self->_dump(ref($data), $data) if $debug;
+ local $Storable::forgive_me = 1; # for CODE refs etc
return freeze($data);
}
sub thaw_data {
my ($self, $frozen_data) = @_;
+ local $Storable::forgive_me = 1; # for CODE refs etc
my $data = thaw($frozen_data);
$self->_dump(ref($data), $data) if $debug;
return $data;
@@ -32,7 +34,8 @@
sub _dump {
my ($self, $label, $data) = @_;
require Data::Dumper;
- warn "$label=".Dumper($data);
+ # XXX dd settings
+ warn "$label=".Data::Dumper::Dumper($data);
}
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Wed Jan 24 08:58:18 2007
@@ -3000,22 +3000,22 @@
# so 'make' creates them and 'make clean' deletes them
my %test_variants = (
pp => { name => "DBI::PurePerl",
- add => [ 'local $ENV{DBI_PUREPERL} = 2;' ],
+ add => [ '$ENV{DBI_PUREPERL} = 2' ],
},
fw => { name => "DBD::Forward",
- add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Forward:transport=null';} ],
+ add => [ q{$ENV{DBI_AUTOPROXY} =
'dbi:Forward:transport=null'} ],
},
- mx => { name => "DBD::Multiplex",
- add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Multiplex:';} ],
- }
+ xpf => { name => "PurePerl & Forward",
+ add => [ q{$ENV{DBI_PUREPERL} = 2; $ENV{DBI_AUTOPROXY}
= 'dbi:Forward:transport=null'} ],
+ },
+ # mx => { name => "DBD::Multiplex",
+ # add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Multiplex:';} ],
+ # }
# px => { name => "DBD::Proxy",
# need mechanism for starting/stopping the proxy server
# add => [ q{local $ENV{DBI_AUTOPROXY} =
'dbi:Proxy:XXX';} ],
# }
);
- # currently many tests fail - DBD::Multiplex needs more work
- # to bring it up to date and improve transparency.
- delete $test_variants{mx}; # unless -f "lib/DBD/Multiplex.pm";
opendir DIR, 't' or die "Can't create variants of tests in 't'
directory: $!";
my @tests = grep { /\.t$/ } readdir DIR;
@@ -3023,18 +3023,19 @@
# XXX one day we may try combinations here, ie pp+mx!
- foreach my $test (sort @tests) {
- next if $test !~ /^[0-8]/;
- my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 &&
$Config{useithreads});
-
- while ( my ($v_type, $v_info) = each %test_variants ) {
- my $v_test = "t/zv${v_type}_$test";
- printf "Creating %-16s test variant: $v_test %s\n",
- $v_info->{name}, ($usethr) ? "(use threads)" : "";
+ while ( my ($v_type, $v_info) = each %test_variants ) {
+ printf "Creating test wrappers for $v_info->{name}:\n";
+
+ foreach my $test (sort @tests) {
+ next if $test !~ /^\d/;
+ my $usethr = ($test =~ /(\d+|\b)thr/ && $] >= 5.008 &&
$Config{useithreads});
+ my $v_test = "t/zv${v_type}_$test";
+ my $v_perl = ($test =~ /taint/) ? "perl -wT" : "perl -w";
+ printf "%s %s\n", $v_test, ($usethr) ? "(use threads)" : "";
open PPT, ">$v_test" or warn "Can't create $v_test: $!";
- print PPT "#!perl -w\n";
+ print PPT "#!$v_perl\n";
print PPT "use threads;\n" if $usethr;
- print PPT "$_\n" foreach @{$v_info->{add}};
+ print PPT "$_;\n" foreach @{$v_info->{add}};
print PPT "do 't/$test' or warn \$!;\n";
print PPT 'die if $@;'."\n";
print PPT "exit 0\n";
Modified: dbi/trunk/lib/DBI/Forward/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Forward/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Forward/Execute.pm Wed Jan 24 08:58:18 2007
@@ -90,7 +90,7 @@
sub execute_dbh_request {
my $request = shift;
my $dbh;
- my $rv = eval {
+ my $rv_ref = eval {
$dbh = _connect($request);
my $meth = $request->dbh_method_name;
my $args = $request->dbh_method_args;
@@ -99,12 +99,19 @@
: scalar $dbh->$meth(@$args);
[EMAIL PROTECTED];
};
- my $response = _new_response_with_err($rv);
+ my $response = _new_response_with_err($rv_ref);
if ($dbh) {
$response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
- if $rv && $request->dbh_last_insert_id_args;
+ if $rv_ref && $request->dbh_last_insert_id_args;
_reset_dbh($dbh);
}
+ if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
+ my $rv = $rv_ref->[0];
+ # dbh_method_call was probably a metadata method like table_info
+ # that returns a statement handle, so turn the $sth into resultset
+ $response->sth_resultsets( _gather_sth_resultsets($rv, $request) );
+ $response->rv("(sth)");
+ }
return $response;
}
@@ -120,18 +127,32 @@
my $meth = $request->dbh_method_name;
my $args = $request->dbh_method_args;
$sth = $dbh->$meth(@$args);
+ my $last = '(sth)'; # a true value
+ # execute methods on the sth, e.g., bind_param & execute
for my $meth_call (@{ $request->sth_method_calls }) {
my $method = shift @$meth_call;
- $sth->$method(@$meth_call);
+ $last = $sth->$method(@$meth_call);
}
-
- $sth->execute();
+ $last;
};
my $response = _new_response_with_err($rv);
- # even if the eval failed we still want to gather attribute values
- my $resultset_list = $sth && eval {
+ # even if the eval failed we still want to try to gather attribute values
+ $response->sth_resultsets( _gather_sth_resultsets($sth, $request) ) if
$sth;
+
+ # 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) if $dbh;
+
+ return $response;
+}
+
+
+sub _gather_sth_resultsets {
+ my ($sth, $request) = @_;
+ return eval {
my $attr_list = $request->sth_result_attr;
$attr_list = [ keys %$attr_list ] if ref $attr_list eq 'HASH';
my $rs_list = [];
@@ -142,14 +163,6 @@
$rs_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) if $dbh;
-
- return $response;
}
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Wed Jan 24 08:58:18 2007
@@ -359,7 +359,7 @@
isa_ok($sth, "DBI::st");
cmp_ok($sth->{NUM_OF_PARAMS}, '==', 0, '... NUM_OF_PARAMS is 0');
- ok(!defined $sth->{NUM_OF_FIELDS}, '... NUM_OF_FIELDS is undefined');
+ is($sth->{NUM_OF_FIELDS}, undef, '... NUM_OF_FIELDS should be undef');
is($sth->{Statement}, "foo bar", '... Statement is "foo bar"');
ok(!defined $sth->{NAME}, '... NAME is undefined');
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Wed Jan 24 08:58:18 2007
@@ -12,7 +12,7 @@
my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';
-use Test::More tests => 216;
+use Test::More tests => 206;
# "globals"
my ($r, $dbh);
@@ -133,7 +133,7 @@
ok($csr_a->{NUM_OF_FIELDS} == 3);
SKIP: {
- skip "dont test for DBI::PurePerl", 3 if $DBI::PurePerl;
+ skip "inner/outer handles not fully supported for DBI::PurePerl", 3 if
$DBI::PurePerl;
ok(tied %{ $csr_a->{Database} }); # ie is 'outer' handle
ok($csr_a->{Database} eq $dbh, "$csr_a->{Database} ne $dbh")
unless $dbh->{mx_handle_list} && ok(1); # skip for Multiplex tests
@@ -141,11 +141,13 @@
}
my $driver_name = $csr_a->{Database}->{Driver}->{Name};
-ok($driver_name eq 'ExampleP');
+ok($driver_name eq 'ExampleP')
+ unless $ENV{DBI_AUTOPROXY} && ok(1);
# --- FetchHashKeyName
$dbh->{FetchHashKeyName} = 'NAME_uc';
my $csr_b = $dbh->prepare($std_sql);
+$csr_b->execute('.');
ok(ref $csr_b);
ok($csr_a != $csr_b);
@@ -347,25 +349,6 @@
# ---
-print "begin_work...\n";
-ok($dbh->{AutoCommit});
-ok(!$dbh->{BegunWork});
-
-ok($dbh->begin_work);
-ok(!$dbh->{AutoCommit});
-ok($dbh->{BegunWork});
-
-$dbh->commit;
-ok($dbh->{AutoCommit});
-ok(!$dbh->{BegunWork});
-
-ok($dbh->begin_work({}));
-$dbh->rollback;
-ok($dbh->{AutoCommit});
-ok(!$dbh->{BegunWork});
-
-# ---
-
print "others...\n";
my $csr_c;
$csr_c = $dbh->prepare("select unknown_field_name1 from ?");
@@ -450,7 +433,7 @@
print "HandleError -> 0 -> RaiseError\n";
$HandleErrorReturn = 0;
ok(! eval { $csr_c = $dbh->prepare($error_sql); 1; });
-ok($@ =~ m/^DBD::(ExampleP|Multiplex)::db prepare failed:/, $@);
+ok($@ =~ m/^DBD::(ExampleP|Multiplex|Forward)::db prepare failed:/, $@);
print "HandleError -> 1 -> return (original)undef\n";
$HandleErrorReturn = 1;
