Author: timbo
Date: Thu Feb 15 08:08:20 2007
New Revision: 9112
Added:
dbi/trunk/lib/DBD/Gofer/Policy/
dbi/trunk/lib/DBD/Gofer/Policy/Base.pm (contents, props changed)
dbi/trunk/lib/DBD/Gofer/Policy/classic.pm (contents, props changed)
dbi/trunk/lib/DBD/Gofer/Policy/pedantic.pm (contents, props changed)
Modified:
dbi/trunk/Changes
dbi/trunk/MANIFEST
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
dbi/trunk/t/08keeperr.t
Log:
Implement 'policy' config mechanism for DBD::Gofer
Fixup last_insert_id handling
(both need testing)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Thu Feb 15 08:08:20 2007
@@ -6,9 +6,10 @@
=cut
-Implement policies
-Add attr-passthru to prepare()
+Implement more policies
Add $dbh->private_attribute_info method
+Add attr-passthru to prepare()?
+Test policies.
=head2 Changes in DBI 1.54 (svn rev 8791), 2nd February 2007
@@ -18,7 +19,7 @@
WARNING: This version has some subtle changes in DBI internals.
It's possible, though doubtful, that some may affect your code.
- I recommend some extra texting before using this release.
+ I recommend some extra testing before using this release.
Or perhaps I'm just being over cautious...
Fixed type_info when called for multiple dbh thanks to Cosimo Streppone.
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Thu Feb 15 08:08:20 2007
@@ -25,6 +25,9 @@
lib/DBD/ExampleP.pm A very simple example Driver module
lib/DBD/File.pm A driver base class for simple drivers
lib/DBD/Gofer.pm DBD::Gofer 'stateless proxy' driver
+lib/DBD/Gofer/Policy/Base.pm
+lib/DBD/Gofer/Policy/pedantic.pm
+lib/DBD/Gofer/Policy/classic.pm
lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport
classes
lib/DBD/Gofer/Transport/http.pm
lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes in same
process (for testing)
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Thu Feb 15 08:08:20 2007
@@ -92,6 +92,7 @@
go_dsn => undef,
go_url => undef,
go_transport => undef,
+ go_policy => undef,
);
$imp_data_size = 0;
@@ -125,6 +126,20 @@
return $drh->set_err(1, "Unknown attributes: @{[ keys %dsn_attr
]}");
}
+ if (not ref $dsn_attr{go_policy}) { # if not a policy object already
+ my $policy_class = $dsn_attr{go_policy} || 'pedantic';
+ $policy_class = "DBD::Gofer::Policy::$policy_class"
+ unless $policy_class =~ /::/;
+ _load_class($policy_class)
+ or return $drh->set_err(1, "Error loading $policy_class: $@");
+ # replace policy name in %dsn_attr with policy object
+ $dsn_attr{go_policy} = eval { $policy_class->new(\%dsn_attr) }
+ or return $drh->set_err(1, "Error instanciating $policy_class:
$@");
+ }
+ # policy object is left in $dsn_attr{go_policy} so transport can see it
+ my $go_policy = $dsn_attr{go_policy};
+
+ my $request_class = "DBI::Gofer::Request";
my $transport_class = delete $dsn_attr{go_transport}
or return $drh->set_err(1, "No transport= argument in
'$orig_dsn'");
$transport_class = "DBD::Gofer::Transport::$transport_class"
@@ -134,7 +149,6 @@
my $go_trans = eval { $transport_class->new(\%dsn_attr) }
or return $drh->set_err(1, "Error instanciating $transport_class:
$@");
- my $request_class = "DBI::Gofer::Request";
my $go_request = eval {
my $go_attr = { %$attr };
# XXX user/pass of fwd server vs db server ? also impact of
autoproxy
@@ -154,19 +168,21 @@
'USER' => $user,
go_trans => $go_trans,
go_request => $go_request,
- go_policy => undef, # XXX
+ go_policy => $go_policy,
});
- $dbh->STORE(Active => 0); # mark as inactive temporarily for STORE
+ # mark as inactive temporarily for STORE. Active not set until
connected() called.
+ $dbh->STORE(Active => 0);
- # test the connection XXX control via a policy later
- unless ($dbh->go_dbh_method(undef, 'ping')) {
- return undef if $dbh->err; # error already recorded, typically
- return $dbh->set_err(1, "ping failed");
+ # should we ping to check the connection
+ # and fetch dbh attributes
+ my $skip_connect_check = $go_policy->skip_connect_check($attr, $dbh);
+ if (not $skip_connect_check) {
+ if (not $dbh->go_dbh_method(undef, 'ping')) {
+ return undef if $dbh->err; # error already recorded, typically
+ return $dbh->set_err(1, "ping failed");
+ }
}
- # unless $policy->skip_connect_ping($attr, $dsn, $user, $auth,
$attr);
-
- # Active not set until connected() called.
return $dbh;
}
@@ -219,12 +235,16 @@
$dbh->{go_response} = $response;
if (my $resultset_list = $response->sth_resultsets) {
+ # dbh method call returned one or more resultsets
+ # (was probably a metadata method like table_info)
+ #
# setup an sth but don't execute/forward it
- my $sth = $dbh->prepare(undef, { go_skip_early_prepare => 1 }); #
XXX
+ my $sth = $dbh->prepare(undef, { go_skip_prepare_check => 1 });
# set the sth response to our dbh response
(tied %$sth)->{go_response} = $response;
- # setup the set with the results in our response
+ # setup the sth with the results in our response
$sth->more_results;
+ # and return that new sth as if it came from original request
$rv = [ $sth ];
}
@@ -268,14 +288,13 @@
my $dbh = shift;
return $dbh->set_err(0, "can't ping while not connected") # warning
unless $dbh->SUPER::FETCH('Active');
- # XXX local or remote - add policy attribute
- return $dbh->go_dbh_method(undef, 'ping', @_);
+ my $skip_ping = $dbh->{go_policy}->skip_ping();
+ return ($skip_ping) ? 1 : $dbh->go_dbh_method(undef, 'ping', @_);
}
sub last_insert_id {
my $dbh = shift;
my $response = $dbh->{go_response} or return undef;
- # will be undef unless last_insert_id was explicitly requested
return $response->last_insert_id;
}
@@ -339,17 +358,14 @@
my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
Statement => $statement,
go_prepare_call => [ 'prepare', $statement, $attr ],
- go_method_calls => [],
+ # go_method_calls => [], # autovivs if needed
go_request => $dbh->{go_request},
go_trans => $dbh->{go_trans},
go_policy => $policy,
});
- #my $skip_early_prepare = $policy->skip_early_prepare($attr, $dbh,
$statement, $attr, $sth);
- my $skip_early_prepare = 0;
-
- $skip_early_prepare = 1 if not defined $statement; # XXX hack, see
go_dbh_method
- if (not $skip_early_prepare) {
+ my $skip_prepare_check = $policy->skip_prepare_check($attr, $dbh,
$statement, $attr, $sth);
+ if (not $skip_prepare_check) {
$sth->go_sth_method() or return undef;
}
@@ -379,13 +395,17 @@
my $request = $sth->{go_request};
$request->init_request($sth->{go_prepare_call}, undef);
- $request->sth_method_calls($sth->{go_method_calls});
- $request->sth_result_attr({});
+ $request->sth_method_calls($sth->{go_method_calls})
+ if $sth->{go_method_calls};
+ $request->sth_result_attr({}); # (currently) indicates this is an sth
request
+
+ $request->last_insert_id_args($sth->{go_last_insert_id_args})
+ if $sth->{go_last_insert_id_args};
my $transport = $sth->{go_trans}
or return $sth->set_err(1, "Not connected (no transport)");
my $TraceLevel = $sth->FETCH('TraceLevel');
- $transport->trace( $TraceLevel - 4 ) if $TraceLevel > 4;
+ $transport->trace( (($TraceLevel-4) > 0) ? $TraceLevel-4 : 0 );
eval { $transport->transmit_request($request) }
or return $sth->set_err(1, "transmit_request failed: $@");
@@ -493,18 +513,26 @@
sub STORE {
my ($sth, $attrib, $value) = @_;
+
return $sth->SUPER::STORE($attrib => $value)
- if $sth_local_store_attrib{$attrib} # handle locally
- or $attrib =~ m/^[a-z]/; # driver-private XXX
+ if $sth_local_store_attrib{$attrib}; # handle locally
- # could perhaps do
- # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ];
- # if not $sth->FETCH('Executed')
+ # otherwise warn but do it anyway
+ # this will probably need refining later
+ my $msg = "Altering \$sth->{$attrib} won't affect proxied handle";
+ Carp::carp($msg) if $sth->FETCH('Warn');
+
+ # XXX could perhaps do
+ # push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ]
+ # if not $sth->FETCH('Executed');
# but how to handle repeat executions? How to we know when an
# attribute is being set to affect the current resultset or the
- # next execution? Could just always use go_method_calls I guess.
- Carp::carp("Can't alter \$sth->{$attrib}") if $sth->FETCH('Warn');
- return $sth->set_err(1, "Can't alter \$sth->{$attrib}");
+ # next execution?
+ # Could just always use go_method_calls I guess.
+
+ $sth->SUPER::STORE($attrib => $value);
+
+ return $sth->set_err(1, $msg);
}
}
@@ -660,6 +688,25 @@
Multiple resultsets are supported if the driver supports the more_results()
method.
+=head1 Use of last_insert_id requires a minor code change
+
+To enable use of last_insert_id you need to indicate to DBD::Gofer that you'd
+like to use it. You do that my adding a C<go_last_insert_id_args> attribute to
+the do() or prepare() method calls. For example:
+
+ $dbh->do($sql, { go_last_insert_id_args => [...] });
+
+or
+
+ $sth = $dbh->prepare($sql, { go_last_insert_id_args => [...] });
+
+The array reference should contains the args that you want passed to the
+last_insert_id() method.
+
+XXX needs testing
+
+XXX allow $dbh->{go_last_insert_id_args} = [] to enable it by default?
+
=head1 TRANSPORTS
DBD::Gofer doesn't concern itself with transporting requests and responses to
and fro.
@@ -713,7 +760,8 @@
The http driver uses the http protocol to send Gofer requests and receive
replies.
-XXX not yet implemented
+The DBI::Gofer::Transport::mod_perl module implements the corresponding
server-side
+transport.
=head1 CONNECTING
@@ -721,18 +769,18 @@
where $transport is the name of the Gofer transport you want to use (see
L</TRANSPORTS>).
The C<transport> and C<dsn> attributes must be specified and the C<dsn>
attributes must be last.
-Other attributes can be specified in the DSN to configure DBD::Gofer and/or
the transport being used.
-
-XXX
+Other attributes can be specified in the DSN to configure DBD::Gofer and/or the
+Gofer transport module being used. The two main attributes after C<transport>,
+are C<url> and C<policy>. These are described below.
=head2 Using DBI_AUTOPROXY
The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment
variable.
-In this case you don't include the C<dsn=> part.
+In this case you don't include the C<dsn=> part. For example:
export DBI_AUTOPROXY=dbi:Gofer:transport=null
-or
+or, for a more useful example, try:
export DBI_AUTOPROXY=dbi:Gofer:transport=stream;url=ssh:[EMAIL PROTECTED]
@@ -749,11 +797,18 @@
You may distribute under the terms of either the GNU General Public License or
the Artistic License, as specified in the Perl README file.
+=head1 ACKNOWLEDGEMENTS
+
+The development of DBD::Gofer and related modules was sponsored by
+Shopzilla.com (L<http://Shopzilla.com>), where I currently work.
+
=head1 SEE ALSO
-L<DBD::Gofer::Request>, L<DBD::Gofer::Response>,
L<DBD::Gofer::Transport::Base>,
+L<DBI::Gofer::Request>, L<DBI::Gofer::Response>, L<DBI::Gofer::Execute>.
+
+L<DBI::Gofer::Transport::Base>
-L<DBI>, L<DBI::Gofer::Execute>.
+L<DBI>
=head1 TODO
Added: dbi/trunk/lib/DBD/Gofer/Policy/Base.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Policy/Base.pm Thu Feb 15 08:08:20 2007
@@ -0,0 +1,58 @@
+package DBD::Gofer::Policy::Base;
+
+# $Id$
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+our $AUTOLOAD;
+
+my %policy_defaults = (
+ skip_connect_check => 0,
+ skip_prepare_check => 0,
+ skip_ping => 0,
+);
+
+my $base_policy_file = $INC{"DBD/Gofer/Policy/Base.pm"};
+
+__PACKAGE__->create_default_policy_subs(\%policy_defaults);
+
+sub create_default_policy_subs {
+ my ($class, $policy_defaults) = @_;
+
+ while ( my ($policy_name, $policy_default) = each %$policy_defaults) {
+ my $policy_attr_name = "go_$policy_name";
+ my $sub = sub {
+ # $policy->foo($attr, ...)
+ #carp "$policy_name($_[1],...)";
+ # return the policy default value unless an attribute overrides it
+ return ($_[1] && exists $_[1]->{$policy_attr_name})
+ ? $_[1]->{$policy_attr_name}
+ : $policy_default;
+ };
+ no strict 'refs';
+ *{$class . '::' . $policy_name} = $sub;
+ }
+}
+
+sub AUTOLOAD {
+ carp "Unknown policy name $AUTOLOAD used";
+ return undef;
+}
+
+sub new {
+ my ($class, $args) = @_;
+ my $policy = {};
+ bless $policy, $class;
+}
+
+sub DESTROY { };
+
+1;
Added: dbi/trunk/lib/DBD/Gofer/Policy/classic.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Policy/classic.pm Thu Feb 15 08:08:20 2007
@@ -0,0 +1,33 @@
+package DBD::Gofer::Policy::classic;
+
+# $Id$
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+
+use base qw(DBD::Gofer::Policy::Base);
+
+__PACKAGE__->create_default_policy_subs({
+
+ # don't skip the connect check since that also sets dbh attributes
+ # although this makes connect more expensive, that's partly offset
+ # by skip_ping=>1 below, which makes connect_cached very fast.
+ skip_connect_check => 0,
+
+ # most code doesn't rely on sth attributes being set after prepare
+ skip_prepare_check => 1,
+
+ # ping is almost meaningless for DBD::Gofer and most transports anyway
+ skip_ping => 1,
+
+});
+
+
+1;
Added: dbi/trunk/lib/DBD/Gofer/Policy/pedantic.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Policy/pedantic.pm Thu Feb 15 08:08:20 2007
@@ -0,0 +1,19 @@
+package DBD::Gofer::Policy::pedantic;
+
+# $Id$
+#
+# Copyright (c) 2007, Tim Bunce, Ireland
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the Perl README file.
+
+use strict;
+use warnings;
+
+our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
+
+use base qw(DBD::Gofer::Policy::Base);
+
+# the 'pedantic' policy is the same as the Base policy
+
+1;
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Thu Feb 15 08:08:20 2007
@@ -220,8 +220,10 @@
};
my $response = $self->new_response_with_err($rv_ref, $@);
if ($dbh) {
- $response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
- if $rv_ref && $request->dbh_last_insert_id_args;
+ if ($rv_ref and my $lid_args = $request->dbh_last_insert_id_args) {
+ my $id = $dbh->last_insert_id( @$lid_args );
+ $response->last_insert_id( $id );
+ }
$self->reset_dbh($dbh);
}
if ($rv_ref and UNIVERSAL::isa($rv_ref->[0],'DBI::st')) {
@@ -239,6 +241,7 @@
my ($self, $request) = @_;
my $dbh;
my $sth;
+ my $last_insert_id;
my $rv = eval {
$dbh = $self->_connect($request);
@@ -249,14 +252,23 @@
my $last = '(sth)'; # a true value (don't try to return actual sth)
# execute methods on the sth, e.g., bind_param & execute
- for my $meth_call (@{ $request->sth_method_calls }) {
- my $method = shift @$meth_call;
- $last = $sth->$method(@$meth_call);
+ if (my $calls = $request->sth_method_calls) {
+ for my $meth_call (@$calls) {
+ my $method = shift @$meth_call;
+ $last = $sth->$method(@$meth_call);
+ }
+ }
+
+ if (my $lid_args = $request->dbh_last_insert_id_args) {
+ $last_insert_id = $dbh->last_insert_id( @$lid_args );
}
+
$last;
};
my $response = $self->new_response_with_err($rv, $@);
+ $response->last_insert_id( $last_insert_id ) if defined $last_insert_id;
+
# even if the eval failed we still want to try to gather attribute values
$response->sth_resultsets( $self->gather_sth_resultsets($sth, $request) )
if $sth;
Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Thu Feb 15 08:08:20 2007
@@ -19,6 +19,7 @@
__PACKAGE__->mk_accessors(qw(
trace
+ go_policy
));
Modified: dbi/trunk/t/08keeperr.t
==============================================================================
--- dbi/trunk/t/08keeperr.t (original)
+++ dbi/trunk/t/08keeperr.t Thu Feb 15 08:08:20 2007
@@ -36,7 +36,7 @@
my $sth = shift;
# we localize an attribute here to check that the correpoding STORE
# at scope exit doesn't clear any recorded error
- local $sth->{dbd_dummy} = 0;
+ local $sth->{Warn} = 0;
my $rv = $sth->SUPER::execute(@_);
return $rv;
}
