Author: timbo
Date: Wed May 9 13:18:11 2007
New Revision: 9537
Modified:
dbi/trunk/DBI.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/t/06attrs.t
Log:
Add FETCH_many method (currently undocumented)
Use it to simplify Gofer/Execute internals.
Now return all sth attribs even if undef - fixes potential bug with multi
resultsets
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Wed May 9 13:18:11 2007
@@ -373,6 +373,7 @@
'CLEAR' => $keeperr,
'EXISTS' => $keeperr,
'FETCH' => { O=>0x0404 },
+ 'FETCH_many' => { O=>0x0404 },
'FIRSTKEY' => $keeperr,
'NEXTKEY' => $keeperr,
'STORE' => { O=>0x0418 | 0x4 },
@@ -1322,6 +1323,11 @@
sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef?
sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" }
+ sub FETCH_many { # should move to C one day
+ my $h = shift;
+ return map { $h->FETCH($_) } @_;
+ }
+
*dump_handle = \&DBI::dump_handle;
sub install_method {
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Wed May 9 13:18:11 2007
@@ -341,8 +341,7 @@
push @req_attr_names, @{ $self->_std_response_attribute_names($dbh) };
}
my %dbh_attr_values;
- # XXX a FETCH_many() method implemented in C would help here
- $dbh_attr_values{$_} = $dbh->FETCH($_) for @req_attr_names;
+ @[EMAIL PROTECTED] = $dbh->FETCH_many(@req_attr_names);
# XXX piggyback installed_methods onto dbh_attributes for now
$dbh_attr_values{dbi_installed_methods} = { DBI->installed_methods };
@@ -454,7 +453,7 @@
}
# XXX needs to be integrated with private_attribute_info() etc
if (my $dbh_attr = $extra_attr{$dbh->{Driver}{Name}}{dbh_after_sth}) {
- $dbh_attr_set->{$_} = $dbh->FETCH($_) for @$dbh_attr;
+ @[EMAIL PROTECTED] = $dbh->FETCH_many(@$dbh_attr);
}
$response->dbh_attributes($dbh_attr_set) if $dbh_attr_set &&
%$dbh_attr_set;
@@ -477,11 +476,12 @@
$sth_attr->{$_} = $sth_result_attr->{$_}
for keys %$sth_result_attr;
}
+ my @sth_attr = grep { $sth_attr->{$_} } keys %$sth_attr;
my $row_count = 0;
my $rs_list = [];
while (1) {
- my $rs = $self->fetch_result_set($sth, $sth_attr);
+ my $rs = $self->fetch_result_set($sth, [EMAIL PROTECTED]);
push @$rs_list, $rs;
if (my $rows = $rs->{rowset}) {
$row_count += @$rows;
@@ -503,24 +503,23 @@
sub fetch_result_set {
- my ($self, $sth, $extra_sth_attr) = @_;
+ my ($self, $sth, $sth_attr) = @_;
my %meta;
- while ( my ($attr,$use) = each %$extra_sth_attr ) {
- next unless $use;
- my $v = eval { $sth->FETCH($attr) };
- if (defined $v) {
- $meta{ $attr } = $v;
- }
- else {
- warn $@ if $@;
- }
- }
- my $NUM_OF_FIELDS = $meta{NUM_OF_FIELDS};
- $NUM_OF_FIELDS = $sth->FETCH('NUM_OF_FIELDS') unless defined
$NUM_OF_FIELDS;
- if ($NUM_OF_FIELDS) { # is a select
- $meta{rowset} = eval { $sth->fetchall_arrayref() };
- $meta{err} = $DBI::err;
- $meta{errstr} = $DBI::errstr;
+ eval {
+ @meta{ @$sth_attr } = $sth->FETCH_many(@$sth_attr);
+ # we assume @$sth_attr contains NUM_OF_FIELDS
+ $meta{rowset} = $sth->fetchall_arrayref()
+ if (($meta{NUM_OF_FIELDS}||0) > 0); # is SELECT
+ # the fetchall_arrayref may fail with a 'not executed' kind of error
+ # because gather_sth_resultsets/fetch_result_set are called even if
+ # execute() failed, or even if there was no execute() call at all.
+ # The corresponding error goes into the resultset err, not the
top-level
+ # response err, so in most cases this resultset err is never noticed.
+ };
+ if ($@) {
+ chomp $@;
+ $meta{err} = $DBI::err || 1;
+ $meta{errstr} = $DBI::errstr || $@;
$meta{state} = $DBI::state;
}
return \%meta;
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Wed May 9 13:18:11 2007
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 144;
+use Test::More tests => 145;
## ----------------------------------------------------------------------------
## 06attrs.t - ...
@@ -74,6 +74,9 @@
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute for dbh');
cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for dbh');
+is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen
ErrCount)) ],
+ [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many';
+
is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh
attribute value';
# Raise an error.
