Author: timbo
Date: Tue Mar 20 15:11:55 2007
New Revision: 9286
Modified:
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Policy/Base.pm
dbi/trunk/lib/DBD/Gofer/Policy/classic.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
dbi/trunk/t/10examp.t
dbi/trunk/t/12quote.t
Log:
Add locally_quote and locally_quote_identifier policy hooks.
Fixup whitespace in DBD::Gofer.
Also forward tables method.
Start work on cache_* policy wrapper for schema metadata methods etc.
Forward prepare_cached.
Improve level 1 gofer trace.
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Tue Mar 20 15:11:55 2007
@@ -46,11 +46,11 @@
dbi_connect_method
);
- our $drh = undef; # holds driver handle once initialised
+ our $drh = undef; # holds driver handle once initialised
our $methods_already_installed;
sub driver{
- return $drh if $drh;
+ return $drh if $drh;
DBI->setup_driver('DBD::Gofer');
@@ -59,15 +59,15 @@
DBD::Gofer::st->install_method('go_sth_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
}
- my($class, $attr) = @_;
- $class .= "::dr";
- ($drh) = DBI::_new_drh($class, {
- 'Name' => 'Gofer',
- 'Version' => $VERSION,
- 'Attribution' => 'DBD Gofer by Tim Bunce',
+ my($class, $attr) = @_;
+ $class .= "::dr";
+ ($drh) = DBI::_new_drh($class, {
+ 'Name' => 'Gofer',
+ 'Version' => $VERSION,
+ 'Attribution' => 'DBD Gofer by Tim Bunce',
});
- $drh;
+ $drh;
}
@@ -288,28 +288,51 @@
return (wantarray) ? @$rv : $rv->[0];
}
- # Methods that should be forwarded
- # XXX get_info? special sub to lazy-cache individual values
+
+ # Methods that should be forwarded but can be cached
for my $method (qw(
- data_sources
- table_info column_info primary_key_info foreign_key_info
statistics_info
- type_info_all get_info
+ tables table_info column_info primary_key_info foreign_key_info
statistics_info
+ data_sources type_info_all get_info
parse_trace_flags parse_trace_flag
func
)) {
+ my $policy_name = "cache_$method";
+ my $sub = sub {
+ my $dbh = shift;
+ # XXX add local (in-handle) cache logic
+ my @rv = (wantarray)
+ ? ($dbh->go_dbh_method(undef, $method, @_))
+ : scalar $dbh->go_dbh_method(undef, $method, @_);
+ return (wantarray) ? @rv : $rv[0];
+ };
no strict 'refs';
- *$method = sub { return shift->go_dbh_method(undef, $method, @_) }
+ *$method = $sub;
}
- # Methods that should be forwarded if policy says so
+
+ # Methods that can use the DBI defaults for some situations/drivers
for my $method (qw(
- quote
- )) {
+ quote quote_identifier
+ )) { # XXX keep DBD::Gofer::Policy::Base in sync
+ my $policy_name = "locally_$method";
+ my $super_name = "SUPER::$method";
+ my $sub = sub {
+ my $dbh = shift;
+ # false: use remote gofer
+ # 1: use local DBI default method
+ # code ref: use the code ref
+ my $locally = $dbh->{go_policy}->$policy_name($dbh, @_);
+ if ($locally) {
+ return $locally->($dbh, @_) if ref $locally eq 'CODE';
+ return $dbh->$super_name(@_);
+ }
+ return $dbh->go_dbh_method(undef, $method, @_);
+ };
no strict 'refs';
- # XXX add policy checks
- *$method = sub { return shift->go_dbh_method(undef, $method, @_) }
+ *$method = $sub;
}
+
# Methods that should always fail
for my $method (qw(
begin_work commit rollback
@@ -318,8 +341,6 @@
*$method = sub { return shift->set_err(1, "$method not available with
DBD::Gofer") }
}
- # for quote we rely on the default method + type_info_all
- # for quote_identifier we rely on the default method + get_info
sub do {
my ($dbh, $sql, $attr, @args) = @_;
@@ -344,7 +365,7 @@
}
sub FETCH {
- my ($dbh, $attrib) = @_;
+ my ($dbh, $attrib) = @_;
# forward driver-private attributes
if ($attrib =~ m/^[a-z]/) { # XXX policy? precache on connect?
@@ -353,17 +374,17 @@
return $value;
}
- # else pass up to DBI to handle
- return $dbh->SUPER::FETCH($attrib);
+ # else pass up to DBI to handle
+ return $dbh->SUPER::FETCH($attrib);
}
sub STORE {
- my ($dbh, $attrib, $value) = @_;
+ my ($dbh, $attrib, $value) = @_;
if ($attrib eq 'AutoCommit') {
return $dbh->SUPER::STORE($attrib => -901) if $value;
croak "Can't enable transactions when using DBD::Gofer";
}
- return $dbh->SUPER::STORE($attrib => $value)
+ return $dbh->SUPER::STORE($attrib => $value)
# we handle this attribute locally
if $dbh_local_store_attrib{$attrib}
# or it's a private_ (application) attribute
@@ -371,7 +392,7 @@
# or not yet connected (and being called by connect())
or not $dbh->FETCH('Active');
- return $dbh->SUPER::STORE($attrib => $value)
+ return $dbh->SUPER::STORE($attrib => $value)
if $DBD::Gofer::xxh_local_store_attrib_if_same_value{$attrib}
&& do { # return true if values are the same
my $crnt = $dbh->FETCH($attrib);
@@ -387,23 +408,21 @@
}
sub disconnect {
- my $dbh = shift;
+ my $dbh = shift;
$dbh->{go_trans} = undef;
- $dbh->STORE(Active => 0);
+ $dbh->STORE(Active => 0);
}
- # XXX + prepare_cached ?
- #
sub prepare {
- my ($dbh, $statement, $attr)= @_;
+ my ($dbh, $statement, $attr)= @_;
return $dbh->set_err(1, "Can't prepare when disconnected")
unless $dbh->FETCH('Active');
my $policy = $attr->{go_policy} || $dbh->{go_policy};
- my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
- Statement => $statement,
+ my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
+ Statement => $statement,
go_prepare_call => [ 'prepare', $statement, $attr ],
# go_method_calls => [], # autovivs if needed
go_request => $dbh->{go_request},
@@ -418,7 +437,15 @@
$sth->go_sth_method() or return undef;
}
- return $sth;
+ return $sth;
+ }
+
+ sub prepare_cached {
+ my ($dbh, @args)= @_;
+ my $sth = $dbh->SUPER::prepare_cached(@args)
+ or return undef;
+ $sth->{go_prepare_call}->[0] = 'prepare_cached';
+ return $sth;
}
}
@@ -519,7 +546,7 @@
sub execute {
- my $sth = shift;
+ my $sth = shift;
$sth->bind_param($_, $_[$_-1]) for ([EMAIL PROTECTED]);
push @{ $sth->{go_method_calls} }, [ 'execute' ];
my $meta = { go_last_insert_id_args => $sth->{go_last_insert_id_args}
};
@@ -528,17 +555,17 @@
sub more_results {
- my $sth = shift;
+ my $sth = shift;
- $sth->finish;
+ $sth->finish;
- my $response = $sth->{go_response} or do {
+ my $response = $sth->{go_response} or do {
# e.g., we haven't sent a request yet (ie prepare then
more_results)
$sth->trace_msg(" No response object present", 3);
return;
};
- my $resultset_list = $response->sth_resultsets
+ my $resultset_list = $response->sth_resultsets
or return $sth->set_err(1, "No sth_resultsets");
my $meta = shift @$resultset_list
@@ -563,28 +590,28 @@
$sth->STORE(Active => 1) if $rowset;
}
- return $sth;
+ return $sth;
}
sub fetchrow_arrayref {
- my ($sth) = @_;
- my $resultset = $sth->{go_current_rowset} || do {
+ my ($sth) = @_;
+ my $resultset = $sth->{go_current_rowset} || do {
# should only happen if fetch called after execute failed
my $rowset_err = $sth->{go_current_rowset_err}
|| [ 1, 'no result set (did execute fail)' ];
return $sth->set_err( @$rowset_err );
};
return $sth->_set_fbav(shift @$resultset) if @$resultset;
- $sth->finish; # no more data so finish
- return undef;
+ $sth->finish; # no more data so finish
+ return undef;
}
*fetch = \&fetchrow_arrayref; # alias
sub fetchall_arrayref {
my ($sth, $slice, $max_rows) = @_;
- my $resultset = $sth->{go_current_rowset} || do {
+ my $resultset = $sth->{go_current_rowset} || do {
# should only happen if fetch called after execute failed
my $rowset_err = $sth->{go_current_rowset_err}
|| [ 1, 'no result set (did execute fail)' ];
@@ -593,7 +620,7 @@
my $mode = ref($slice) || 'ARRAY';
return $sth->SUPER::fetchall_arrayref($slice, $max_rows)
if ref($slice) or defined $max_rows;
- $sth->finish; # no more data after this so finish
+ $sth->finish; # no more data after this so finish
return $resultset;
}
@@ -604,9 +631,9 @@
sub STORE {
- my ($sth, $attrib, $value) = @_;
+ my ($sth, $attrib, $value) = @_;
- return $sth->SUPER::STORE($attrib => $value)
+ return $sth->SUPER::STORE($attrib => $value)
if $sth_local_store_attrib{$attrib} # handle locally
# or it's a private_ (application) attribute
or $attrib =~ /^private_/;
@@ -625,7 +652,7 @@
# Could just always use go_method_calls I guess.
# do the store locally anyway, just in case
- $sth->SUPER::STORE($attrib => $value);
+ $sth->SUPER::STORE($attrib => $value);
return $sth->set_err(1, $msg);
}
Modified: dbi/trunk/lib/DBD/Gofer/Policy/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Policy/Base.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Policy/Base.pm Tue Mar 20 15:11:55 2007
@@ -20,6 +20,8 @@
skip_ping => 0,
dbh_attribute_update => 'every',
dbh_attribute_list => ['*'],
+ locally_quote => 0,
+ locally_quote_identifier => 0,
);
my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"};
@@ -46,6 +48,9 @@
sub AUTOLOAD {
carp "Unknown policy name $AUTOLOAD used";
+ # only warn once
+ no strict 'refs';
+ *$AUTOLOAD = sub { undef };
return undef;
}
Modified: dbi/trunk/lib/DBD/Gofer/Policy/classic.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Policy/classic.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Policy/classic.pm Tue Mar 20 15:11:55 2007
@@ -27,6 +27,9 @@
# ping is almost meaningless for DBD::Gofer and most transports anyway
skip_ping => 1,
+ # we'd like to set locally_* but can't because drivers differ
+
+ # XXX we could set some cache_* though
});
Modified: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Request.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Tue Mar 20 15:11:55 2007
@@ -57,11 +57,15 @@
my @s = '';
my ($dsn, $attr) = @{ $self->connect_args };
- push @s, "dbh= connect('$dsn', , , { %{$attr||{}} ]} })";
+ push @s, sprintf "dbh= connect('%s', , , { %s })", $dsn, neat_list([
%{$attr||{}} ]);
my ($meth, @args) = @{ $self->dbh_method_call };
push @s, sprintf "dbh->%s(%s)", $meth, neat_list([EMAIL PROTECTED]);
+ if (my $lii_args = $self->dbh_last_insert_id_args) {
+ push @s, sprintf "dbh->last_insert_id(%s)", neat_list($lii_args);
+ }
+
for my $call (@{ $self->sth_method_calls || [] }) {
my ($meth, @args) = @$call;
push @s, sprintf "sth->%s(%s)", $meth, neat_list([EMAIL PROTECTED]);
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Tue Mar 20 15:11:55 2007
@@ -82,20 +82,28 @@
sub summary_as_text {
my $self = shift;
my ($rv, $err, $errstr, $state) = ($self->{rv}, $self->{err},
$self->{errstr}, $self->{state});
- my @s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : $rv);
- $s[-1] .= sprintf(" err=%s errstr=%s", $err, neat($errstr)) if defined
$err;
+ my @s = sprintf("rv=%s", (ref $rv) ? "[".neat_list($rv)."]" : neat($rv));
+ $s[-1] .= sprintf(" err=%s, errstr=%s", $err, neat($errstr))
+ if defined $err;
+ push @s, "last_insert_id=%s", $self->last_insert_id
+ if defined $self->last_insert_id;
for my $rs (@{$self->sth_resultsets || []}) {
my ($rowset, $err, $errstr, $state)
= @{$rs}{qw(rowset err errstr state)};
my $summary = "rowset: ";
- if ($rowset || $rs->{NUM_OF_FIELDS} > 0) {
- $summary .= sprintf "%d rows, %d columns", scalar @{$rowset||[]},
$rs->{NUM_OF_FIELDS}
+ my $NUM_OF_FIELDS = $rs->{NUM_OF_FIELDS} || 0;
+ if ($rowset || $NUM_OF_FIELDS > 0) {
+ $summary .= sprintf "%d rows, %d columns", scalar @{$rowset||[]},
$NUM_OF_FIELDS
}
if (defined $err) {
$summary .= sprintf(", err=%s errstr=%s", $err, neat($errstr))
}
push @s, $summary;
}
+ for my $w (@{$self->warnings || []}) {
+ chomp $w;
+ push @s, "warning: $w";
+ }
return join("\n\t", @s). "\n";
}
Modified: dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm Tue Mar 20 15:11:55 2007
@@ -246,7 +246,7 @@
The DBI::Gofer::Transport::mod_perl->configuration({...}) call defines named
configurations.
The C<PerlSetVar GoferConfig> clause specifies the configuration to be used
for that location.
-XXX add detail inclusing specific examples
+XXX add detail including specific examples
A single location can specify multiple configurations using C<PerlAddVar>:
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Tue Mar 20 15:11:55 2007
@@ -548,15 +548,18 @@
}
-print "Testing \$dbh->func().\n";
-my %tables;
-unless ($dbh->{mx_handle_list}) {
- %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables();
- foreach my $t ($dbh->func('lib', 'examplep_tables')) {
- defined(delete $tables{$t}) or print "Unexpected table: $t\n";
- }
+SKIP: {
+ skip "test not tested with Multiplex", 1
+ if $dbh->{mx_handle_list};
+ print "Testing \$dbh->func().\n";
+ my %tables;
+ %tables = map { $_ =~ /lib/ ? ($_, 1) : () } $dbh->tables();
+ my @func_tables = $dbh->func('lib', 'examplep_tables');
+ foreach my $t (@func_tables) {
+ defined(delete $tables{$t}) or print "Unexpected table: $t\n";
+ }
+ is(keys(%tables), 0);
}
-ok((%tables == 0));
$dbh->disconnect;
ok(!$dbh->{Active});
Modified: dbi/trunk/t/12quote.t
==============================================================================
--- dbi/trunk/t/12quote.t (original)
+++ dbi/trunk/t/12quote.t Tue Mar 20 15:11:55 2007
@@ -19,19 +19,13 @@
is($dbh->quote("quote's"), "'quote''s'", '... quoting strings
with embedded single quotes');
is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as
SQL_VARCHAR');
is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as
SQL_INTEGER');
- is($dbh->quote(undef), "NULL", '...
quoting undef as NULL');
+ is($dbh->quote(undef), "NULL", '... quoting undef as
NULL');
}
check_quote();
sub check_quote_identifier {
- my $qi = $dbh->{dbi_quote_identifier_cache} = [
- '"', # 29: SQL_IDENTIFIER_QUOTE_CHAR
- '.', # 41: SQL_CATALOG_NAME_SEPARATOR
- 1, # 114: SSQL_CATALOG_LOCATION
- ];
-
is($dbh->quote_identifier('foo'), '"foo"', '...
properly quotes foo as "foo"');
is($dbh->quote_identifier('f"o'), '"f""o"', '...
properly quotes f"o as "f""o"');
is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '...
properly quotes foo, bar as "foo"."bar"');
@@ -39,9 +33,14 @@
is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '...
properly quotes foo, undef, bar as "foo"."bar"');
+ SKIP: {
+ skip "Can't test alternate quote_identifier logic with DBI_AUTOPROXY",
1
+ if $ENV{DBI_AUTOPROXY};
+ my $qi = $dbh->{dbi_quote_identifier_cache} || die "test out of date
with dbi internals?";
$qi->[1] = '@'; # SQL_CATALOG_NAME_SEPARATOR
$qi->[2] = 2; # SQL_CATALOG_LOCATION
is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now
quotes it as "bar"@"foo" after flushing cache');
+ }
}
check_quote_identifier();
