Author: timbo
Date: Wed May 9 08:24:30 2007
New Revision: 9532
Modified:
dbi/trunk/DBI.pm
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/t/06attrs.t
Log:
Fix driver-private sth attributes via gofer.
Add way for gofer executor config to enable extra dbh/sth to be returned with
responses.
Add tests for above.
Add valid_configuration_attributes executor method.
Optimize caching of standard response attributes.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Wed May 9 08:24:30 2007
@@ -9,7 +9,7 @@
require 5.006_00;
BEGIN {
-$DBI::VERSION = "1.55"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.56"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -120,7 +120,7 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.55
+This is the DBI specification that corresponds to the DBI version 1.56
($Revision$).
The DBI is evolving at a steady pace, so it's good to check that
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Wed May 9 08:24:30 2007
@@ -59,14 +59,17 @@
sub connect { # normally overridden, but a handy default
my($drh, $dbname, $user, $auth)= @_;
- my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dbname });
- $dbh->STORE('Active', 1);
+ my ($outer, $dbh) = DBI::_new_dbh($drh, {
+ Name => $dbname,
+ examplep_private_dbh_attrib => 42, # an example, for testing
+ });
$dbh->{examplep_get_info} = {
29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR
41 => '.', # SQL_CATALOG_NAME_SEPARATOR
114 => 1, # SQL_CATALOG_LOCATION
};
- $dbh->{Name} = $dbname;
+ #$dbh->{Name} = $dbname;
+ $dbh->STORE('Active', 1);
return $outer;
}
@@ -101,6 +104,7 @@
my ($outer, $sth) = DBI::_new_sth($dbh, {
'Statement' => $statement,
+ examplep_private_sth_attrib => 24, # an example, for testing
}, ['example implementors private data '.__PACKAGE__]);
my @bad = map {
@@ -111,7 +115,7 @@
$outer->STORE('NUM_OF_FIELDS' => scalar(@fields));
- $sth->{dbd_ex_dir} = $dir if defined($dir) && $dir !~ /\?/;
+ $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/;
$outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0);
if (@fields) {
@@ -307,7 +311,7 @@
return 0 unless $sth->{NUM_OF_FIELDS}; # not a select
- $dir = $dbd_param->[0] || $sth->{dbd_ex_dir};
+ $dir = $dbd_param->[0] || $sth->{examplep_ex_dir};
return $sth->set_err(2, "No bind parameter supplied")
unless defined $dir;
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Wed May 9 08:24:30 2007
@@ -1035,7 +1035,7 @@
=head2 Other Transports
-Implementing a transport is very simple, and more transports are very welcome.
+Implementing a Gofer transport is I<very> simple, and more transports are very
welcome.
Just take a look at any existing transports that are similar to your needs.
=head3 http
@@ -1045,7 +1045,7 @@
=head3 Gearman
I know Ask Bj�rn Hansen has implemented a transport for the C<gearman>
distributed
-job system, though it's not yet on CPAN.
+job system, though it's not on CPAN at the time of writing this.
=head1 CONNECTING
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 08:24:30 2007
@@ -32,18 +32,26 @@
DBI->trace(split /=/, $ENV{DBI_GOFER_TRACE}, 2) if $ENV{DBI_GOFER_TRACE};
-__PACKAGE__->mk_accessors(qw(
- check_request_sub
- default_connect_dsn
- forced_connect_dsn
- default_connect_attributes
- forced_connect_attributes
- forced_single_resultset
- max_cached_dbh_per_drh
- max_cached_sth_per_dbh
- track_recent
- stats
-));
+# define valid configuration attributes (args to new())
+# the values here indicate the basic type of values allowed
+my %configuration_attributes = (
+ default_connect_dsn => 1,
+ forced_connect_dsn => 1,
+ default_connect_attributes => {},
+ forced_connect_attributes => {},
+ track_recent => 1,
+ check_request_sub => sub {},
+ forced_single_resultset => 1,
+ max_cached_dbh_per_drh => 1,
+ max_cached_sth_per_dbh => 1,
+ forced_response_attributes => {},
+ stats => {},
+);
+
+__PACKAGE__->mk_accessors(
+ keys %configuration_attributes
+);
+
sub new {
@@ -56,19 +64,15 @@
}
-my @sth_std_attr = qw(
- NUM_OF_PARAMS
- NUM_OF_FIELDS
- NAME
- TYPE
- NULLABLE
- PRECISION
- SCALE
-);
+sub valid_configuration_attributes {
+ my $self = shift;
+ return { %configuration_attributes };
+}
+
my %extra_attr = (
# Only referenced if the driver doesn't support private_attribute_info
method.
- # what driver-specific attributes should be returned for the driver being
used?
+ # What driver-specific attributes should be returned for the driver being
used?
# keyed by $dbh->{Driver}{Name}
# XXX for sth should split into attr specific to resultsets (where
NUM_OF_FIELDS > 0) and others
# which would reduce processing/traffic for non-select statements
@@ -113,6 +117,17 @@
sth => [qw(
)],
},
+ ExampleP => {
+ dbh => [qw(
+ examplep_private_dbh_attrib
+ )],
+ sth => [qw(
+ examplep_private_sth_attrib
+ )],
+ dbh_after_sth => [qw(
+ examplep_insertid
+ )],
+ },
);
@@ -323,9 +338,10 @@
my @req_attr_names = @$dbh_attributes;
if ($req_attr_names[0] eq '*') { # auto include std + private
shift @req_attr_names;
- push @req_attr_names, @{ $self->_get_std_attributes($dbh) };
+ 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;
# XXX piggyback installed_methods onto dbh_attributes for now
@@ -338,24 +354,48 @@
}
-sub _get_std_attributes {
+sub _std_response_attribute_names {
my ($self, $h) = @_;
$h = tied(%$h) || $h; # switch to inner handle
- my $attr_names = $h->{private_gofer_std_attr_names};
- return $attr_names if $attr_names;
- # 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);
+
+ # cache the private_attribute_info data for each handle
+ # XXX might be better to cache it in the executor
+ # as it's unlikely to change
+ # or perhaps at least cache it in the dbh even for sth
+ # as the sth are typically very short lived
+
+ my ($dbh, $h_type, $driver_name, @attr_names);
+
+ if ($dbh = $h->{Database}) { # is an sth
+
+ # does the dbh already have the answer cached?
+ return $dbh->{private_gofer_std_attr_names_sth} if
$dbh->{private_gofer_std_attr_names_sth};
+
+ ($h_type, $driver_name) = ('sth', $dbh->{Driver}{Name});
+ push @attr_names, qw(NUM_OF_PARAMS NUM_OF_FIELDS NAME TYPE NULLABLE
PRECISION SCALE);
+ }
+ else { # is a dbh
+ return $h->{private_gofer_std_attr_names_dbh} if
$h->{private_gofer_std_attr_names_dbh};
+
+ ($h_type, $driver_name, $dbh) = ('dbh', $h->{Driver}{Name}, $h);
+ # explicitly add these because drivers may have different defaults
+ # add Name so the client gets the real Name of the connection
+ push @attr_names, qw(ChopBlanks LongReadLen LongTruncOk ReadOnly Name);
+ }
+
if (my $pai = $h->private_attribute_info) {
push @attr_names, keys %$pai;
}
- elsif (my $drh = $h->{Driver}) { # is a dbh
- push @attr_names, @{ $extra_attr{ $drh->{Name} }{dbh} || []};
+ else {
+ push @attr_names, @{ $extra_attr{ $driver_name }{$h_type} || []};
}
- elsif ($drh = $h->{Driver}{Database}) { # is an sth
- push @attr_names, @{ $extra_attr{ $drh->{Name} }{sth} || []};
+ if (my $fra = $self->{forced_response_attributes}) {
+ push @attr_names, @{ $fra->{ $driver_name }{$h_type} || []}
}
- return $h->{private_gofer_std_attr_names} = [EMAIL PROTECTED];
+ $dbh->trace_msg("_std_response_attribute_names for $driver_name $h_type:
@attr_names\n");
+
+ # cache into the dbh even for sth, as the dbh is usually longer lived
+ return $dbh->{"private_gofer_std_attr_names_$h_type"} = [EMAIL PROTECTED];
}
@@ -412,6 +452,7 @@
if (my $dbh_attributes = $request->dbh_attributes) {
$dbh_attr_set = $self->gather_dbh_attributes($dbh, $dbh_attributes);
}
+ # 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;
}
@@ -426,11 +467,10 @@
sub gather_sth_resultsets {
my ($self, $sth, $request, $response) = @_;
my $resultsets = eval {
- my $driver_name = $sth->{Database}{Driver}{Name};
- my $extra_sth_attr = $extra_attr{$driver_name}{sth} || [];
+ my $attr_names = $self->_std_response_attribute_names($sth);
my $sth_attr = {};
- $sth_attr->{$_} = 1 for (@sth_std_attr, @$extra_sth_attr);
+ $sth_attr->{$_} = 1 for @$attr_names;
# let the client add/remove sth atributes
if (my $sth_result_attr = $request->sth_result_attr) {
@@ -669,12 +709,25 @@
Note that this setting can significantly increase memory use. Use with caution.
-=head1 AUTHOR AND COPYRIGHT
+=head1 DRIVER-SPECIFIC ISSUES
+
+Gofer needs to know about any driver-private attributes that should have their
+values sent back to the client.
+
+If the driver doesn't support private_attribute_info() method, and very few do,
+then the module fallsback to using some hard-coded details, if available, for
+the driver being used. Currently hard-coded details are available for the
+mysql, Pg, Sybase, and SQLite drivers.
+
+=head1 AUTHOR
+
+Tim Bunce, L<http://www.linkedin.com/in/timbunce>
+
+=head1 LICENCE AND COPYRIGHT
-The DBD::Gofer, DBD::Gofer::* and DBI::Gofer::* modules are
-Copyright (c) 2007 Tim Bunce. Ireland. All rights reserved.
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
-You may distribute under the terms of either the GNU General Public License or
-the Artistic License, as specified in the Perl README file.
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
=cut
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Wed May 9 08:24:30 2007
@@ -151,11 +151,15 @@
1;
-=head1 AUTHOR AND COPYRIGHT
-The DBD::Gofer, DBD::Gofer::* and DBI::Gofer::* modules are
-Copyright (c) 2007 Tim Bunce. Ireland. All rights reserved.
+=head1 AUTHOR
-You may distribute under the terms of either the GNU General Public License or
-the Artistic License, as specified in the Perl README file.
+Tim Bunce, L<http://www.linkedin.com/in/timbunce>
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Tim Bunce, Ireland. All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Wed May 9 08:24:30 2007
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 142;
+use Test::More tests => 144;
## ----------------------------------------------------------------------------
## 06attrs.t - ...
@@ -74,6 +74,8 @@
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking
TraceLevel attribute for dbh');
cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking
LongReadLen attribute for dbh');
+is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh
attribute value';
+
# Raise an error.
eval {
$dbh->do('select foo from foo')
@@ -274,6 +276,8 @@
is($sth->{Statement}, "select ctime, name from ?", '... checking Statement
attribute for sth');
ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute
for sth');
+is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth
attribute value';
+
# $h->{TraceLevel} tests are in t/09trace.t
print "Checking inheritance\n";
