Author: timbo
Date: Mon Jan 29 05:21:16 2007
New Revision: 8745
Added:
dbi/trunk/lib/DBD/Gofer/
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBD/Gofer/Transport/null.pm
dbi/trunk/lib/DBI/Gofer/
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Request.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/lib/DBI/Gofer/Transport/
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
dbi/trunk/t/85gofer.t
Removed:
dbi/trunk/lib/DBD/Forward/
dbi/trunk/lib/DBD/Forward.pm
dbi/trunk/lib/DBI/Forward/
dbi/trunk/t/85forward.t
Modified:
dbi/trunk/MANIFEST
Log:
Delete DBD::Forward and add DBD::Gofer (with many changes)
Modified: dbi/trunk/MANIFEST
==============================================================================
--- dbi/trunk/MANIFEST (original)
+++ dbi/trunk/MANIFEST Mon Jan 29 05:21:16 2007
@@ -24,9 +24,9 @@
lib/DBD/DBM.pm A driver for DBM files (uses DBD::File)
lib/DBD/ExampleP.pm A very simple example Driver module
lib/DBD/File.pm A driver base class for simple drivers
-lib/DBD/Forward.pm DBD::Forward 'stateless proxy' driver
-lib/DBD/Forward/Transport/Base.pm Base class for DBD::Forward driver transport
classes
-lib/DBD/Forward/Transport/null.pm DBD::Forward transport that executes locally
(for testing)
+lib/DBD/Gofer.pm DBD::Gofer 'stateless proxy' driver
+lib/DBD/Gofer/Transport/Base.pm Base class for DBD::Gofer driver transport
classes
+lib/DBD/Gofer/Transport/null.pm DBD::Gofer transport that executes locally
(for testing)
lib/DBD/NullP.pm An empty example Driver module
lib/DBD/Proxy.pm Proxy driver
lib/DBD/Sponge.pm A driver for fake cursors (precached data)
@@ -37,10 +37,10 @@
lib/DBI/DBD.pm Some basic help for people writing DBI drivers
lib/DBI/DBD/Metadata.pm Metadata tools for people writing DBI
drivers
lib/DBI/FAQ.pm The DBI FAQ in module form for perldoc
-lib/DBI/Forward/Execute.pm Execution logic for DBD::Forward server
-lib/DBI/Forward/Request.pm Request object from DBD::Forward
-lib/DBI/Forward/Response.pm Response object for DBD::Forward
-lib/DBI/Forward/Transport/Base.pm Base class for DBD::Forward server transport
classes
+lib/DBI/Gofer/Execute.pm Execution logic for DBD::Gofer server
+lib/DBI/Gofer/Request.pm Request object from DBD::Gofer
+lib/DBI/Gofer/Response.pm Response object for DBD::Gofer
+lib/DBI/Gofer/Transport/Base.pm Base class for DBD::Gofer server transport
classes
lib/DBI/Profile.pm Manage DBI usage profile data
lib/DBI/ProfileData.pm
lib/DBI/ProfileDumper.pm
@@ -79,7 +79,7 @@
t/70callbacks.t
t/72childhandles.t
t/80proxy.t
-t/85forward.t
+t/85gofer.t
t/pod.t
test.pl Assorted informal tests, including tests for
memory leaks
typemap
Added: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,652 @@
+{
+ package DBD::Gofer;
+
+ use strict;
+
+ require DBI;
+ require DBI::Gofer::Request;
+ require DBI::Gofer::Response;
+ require Carp;
+
+ our $VERSION = sprintf("0.%06d", q$Revision: 8705 $ =~ /(\d+)/o);
+
+# $Id: Gofer.pm 8705 2007-01-26 01:08:25Z timbo $
+#
+# 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.
+
+
+
+ # attributes we'll allow local STORE
+ our %xxh_local_store_attrib = map { $_=>1 } qw(
+ Active
+ CachedKids
+ Callbacks
+ ErrCount Executed
+ FetchHashKeyName
+ HandleError HandleSetErr
+ InactiveDestroy
+ PrintError PrintWarn
+ Profile
+ RaiseError
+ RootClass
+ ShowErrorStatement
+ Taint TaintIn TaintOut
+ TraceLevel
+ Warn
+ dbi_quote_identifier_cache
+ dbi_connect_closure
+ dbi_go_execute_unique
+ );
+ our %xxh_local_store_if_same_attrib = map { $_=>1 } qw(
+ Username
+ dbi_connect_method
+ );
+
+ our $drh = undef; # holds driver handle once initialised
+ our $methods_already_installed;
+
+ sub driver{
+ return $drh if $drh;
+
+ DBI->setup_driver('DBD::Gofer');
+
+ unless ($methods_already_installed++) {
+ DBD::Gofer::db->install_method('go_dbh_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
+ 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',
+ });
+
+ $drh;
+ }
+
+ sub CLONE {
+ undef $drh;
+ }
+
+}
+
+
+{ package DBD::Gofer::dr; # ====== DRIVER ======
+
+ my %dsn_attr_defaults = (
+ go_dsn => undef,
+ go_url => undef,
+ go_transport => undef,
+ );
+
+ $imp_data_size = 0;
+ use strict;
+
+ sub connect {
+ my($drh, $dsn, $user, $auth, $attr)= @_;
+ my $orig_dsn = $dsn;
+
+ # first remove dsn= and everything after it
+ my $go_dsn = ($dsn =~ s/\bdsn=(.*)$// && $1)
+ or return $drh->set_err(1, "No dsn= argument in '$orig_dsn'");
+
+ my %dsn_attr = (%dsn_attr_defaults, go_dsn => $go_dsn);
+ # extract any go_ attributes from the connect() attr arg
+ for my $k (grep { /^go_/ } keys %$attr) {
+ $dsn_attr{$k} = delete $attr->{$k};
+ }
+ # then override those with any attributes embedded in our dsn (not
go_dsn)
+ for my $kv (grep /=/, split /;/, $dsn, -1) {
+ my ($k, $v) = split /=/, $kv, 2;
+ $dsn_attr{ "go_$k" } = $v;
+ }
+ if (keys %dsn_attr > keys %dsn_attr_defaults) {
+ delete @dsn_attr{ keys %dsn_attr_defaults };
+ return $drh->set_err(1, "Unknown attributes: @{[ keys %dsn_attr
]}");
+ }
+
+ my $transport_class = $dsn_attr{go_transport}
+ or return $drh->set_err(1, "No transport= argument in
'$orig_dsn'");
+ $transport_class = "DBD::Gofer::Transport::$dsn_attr{go_transport}"
+ unless $transport_class =~ /::/;
+ eval "require $transport_class"
+ or return $drh->set_err(1, "Error loading $transport_class: $@");
+ my $go_trans = eval { $transport_class->new(\%dsn_attr) }
+ or return $drh->set_err(1, "Error instanciating $transport_class:
$@");
+
+ # XXX user/pass of fwd server vs db server
+ my $request_class = "DBI::Gofer::Request";
+ my $go_request = eval {
+ # copy and delete any attributes we can't serialize (and don't
want to)
+ my $go_attr = { %$attr };
+ delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)};
+ $request_class->new({
+ connect_args => [ $go_dsn, $user, $auth, $go_attr ]
+ })
+ } or return $drh->set_err(1, "Error instanciating $request_class $@");
+
+ my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
+ 'Name' => $dsn,
+ 'USER' => $user,
+ go_trans => $go_trans,
+ go_request => $go_request,
+ go_policy => undef, # XXX
+ });
+
+ $dbh->STORE(Active => 0); # mark as inactive temporarily for STORE
+
+ # test the connection XXX control via a policy later
+ unless ($dbh->go_dbh_method('ping', undef)) {
+ 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;
+ }
+
+ sub DESTROY { undef }
+}
+
+
+{ package DBD::Gofer::db; # ====== DATABASE ======
+ $imp_data_size = 0;
+ use strict;
+ use Carp qw(croak);
+
+ my %dbh_local_store_attrib = %DBD::Gofer::xxh_local_store_attrib;
+
+ sub connected {
+ shift->STORE(Active => 1);
+ }
+
+ sub go_dbh_method {
+ my ($dbh, $method, $meta, @args) = @_;
+ my $request = $dbh->{go_request};
+ $request->init_request($method, [EMAIL PROTECTED], wantarray);
+
+ my $transport = $dbh->{go_trans}
+ or return $dbh->set_err(1, "Not connected (no transport)");
+
+ eval { $transport->transmit_request($request) }
+ or return $dbh->set_err(1, "transmit_request failed: $@");
+
+ my $response = $transport->receive_response;
+ my $rv = $response->rv;
+
+ $dbh->{go_response} = $response;
+
+ if (my $resultset_list = $response->sth_resultsets) {
+ # setup an sth but don't execute/forward it
+ my $sth = $dbh->prepare(undef, { go_skip_early_prepare => 1 }); #
XXX
+ # set the sth response to our dbh response
+ (tied %$sth)->{go_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);
+
+ return (wantarray) ? @$rv : $rv->[0];
+ }
+
+ # Methods that should be forwarded
+ # XXX get_info? special sub to lazy-cache individual values
+ for my $method (qw(
+ data_sources
+ table_info column_info primary_key_info foreign_key_info
statistics_info
+ type_info_all get_info
+ parse_trace_flags parse_trace_flag
+ func
+ )) {
+ no strict 'refs';
+ *$method = sub { return shift->go_dbh_method($method, undef, @_) }
+ }
+
+ # Methods that should always fail
+ for my $method (qw(
+ begin_work commit rollback
+ )) {
+ no strict 'refs';
+ *$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 = shift;
+ delete $dbh->{Statement}; # avoid "Modification of non-creatable hash
value attempted"
+ $dbh->{Statement} = $_[0]; # for profiling and ShowErrorStatement
+ return $dbh->go_dbh_method('do', undef, @_);
+ }
+
+ sub ping {
+ 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('ping', undef, @_);
+ }
+
+ 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;
+ }
+
+ sub FETCH {
+ my ($dbh, $attrib) = @_;
+
+ # forward driver-private attributes
+ if ($attrib =~ m/^[a-z]/) { # XXX policy? precache on connect?
+ my $value = $dbh->go_dbh_method('FETCH', undef, $attrib);
+ $dbh->{$attrib} = $value;
+ return $value;
+ }
+
+ # else pass up to DBI to handle
+ return $dbh->SUPER::FETCH($attrib);
+ }
+
+ sub STORE {
+ 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)
+ # we handle this attribute locally
+ if $dbh_local_store_attrib{$attrib}
+ # not yet connected (and being called by connect())
+ or not $dbh->FETCH('Active');
+
+ return $dbh->SUPER::STORE($attrib => $value)
+ if $DBD::Gofer::xxh_local_store_if_same_attrib{$attrib}
+ && do { local $^W; $value eq $dbh->FETCH($attrib) }; # XXX undefs
+
+ # dbh attributes are set at connect-time - see connect()
+ Carp::carp("Can't alter \$dbh->{$attrib}");
+ return $dbh->set_err(1, "Can't alter \$dbh->{$attrib}");
+ }
+
+ sub disconnect {
+ my $dbh = shift;
+ $dbh->{go_trans} = undef;
+ $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 $policy = $attr->{go_policy} || $dbh->{go_policy};
+
+ my ($sth, $sth_inner) = DBI::_new_sth($dbh, {
+ Statement => $statement,
+ go_prepare_call => [ 'prepare', [ $statement, $attr ] ],
+ go_method_calls => [],
+ go_request => $dbh->{go_request},
+ go_trans => $dbh->{go_trans},
+ go_policy => $policy,
+ });
+
+ #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 go_dbh_method
+ if (not $p_sep) {
+ $sth->go_sth_method() or return undef;
+ }
+
+ return $sth;
+ }
+
+}
+
+
+{ package DBD::Gofer::st; # ====== STATEMENT ======
+ $imp_data_size = 0;
+ use strict;
+
+ my %sth_local_store_attrib = (%DBD::Gofer::xxh_local_store_attrib,
NUM_OF_FIELDS => 1);
+
+ sub go_sth_method {
+ my ($sth) = @_;
+
+ if (my $ParamValues = $sth->{ParamValues}) {
+ my $ParamAttr = $sth->{ParamAttr};
+ while ( my ($p, $v) = each %$ParamValues) {
+ # unshift to put binds before execute call
+ unshift @{ $sth->{go_method_calls} },
+ [ 'bind_param', $p, $v, $ParamAttr->{$p} ];
+ }
+ }
+
+ 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({});
+
+ my $transport = $sth->{go_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->{go_response} = $response;
+ delete $sth->{go_method_calls};
+
+ if ($response->sth_resultsets) {
+ # setup first resultset - including atributes
+ $sth->more_results;
+ }
+ else {
+ $sth->{go_rows} = $response->rv;
+ }
+ # set error/warn/info (after more_results as that'll clear err)
+ $sth->set_err($response->err, $response->errstr, $response->state);
+
+ return $response->rv;
+ }
+
+
+ # 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::Gofer, 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->{go_method_calls} }, [ 'execute' ];
+ return $sth->go_sth_method;
+ }
+
+
+ sub more_results {
+ my ($sth) = @_;
+
+ $sth->finish if $sth->FETCH('Active');
+
+ my $resultset_list = $sth->{go_response}->sth_resultsets
+ or return $sth->set_err(1, "No sth_resultsets");
+
+ my $meta = shift @$resultset_list
+ or return undef; # no more result sets
+
+ # pull out the special non-atributes first
+ my ($rowset, $err, $errstr, $state)
+ = delete @{$meta}{qw(rowset err errstr state)};
+
+ # copy meta attributes into attribute cache
+ 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) > 0) {
+ $sth->{go_rows} = ($rowset) ? @$rowset : -1;
+ $sth->{go_current_rowset} = $rowset;
+ $sth->{go_current_rowset_err} = [ $err, $errstr, $state ]
+ if defined $err;
+ $sth->STORE(Active => 1) if $rowset;
+ }
+
+ return $sth;
+ }
+
+
+ sub fetchrow_arrayref {
+ my ($sth) = @_;
+ my $resultset = $sth->{go_current_rowset}
+ or return $sth->set_err( @{ $sth->{go_current_rowset_err} } );
+ return $sth->_set_fbav(shift @$resultset) if @$resultset;
+ $sth->finish; # no more data so finish
+ return undef;
+ }
+ *fetch = \&fetchrow_arrayref; # alias
+
+
+ sub fetchall_arrayref {
+ 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->{go_current_rowset}
+ or return $sth->set_err( @{ $sth->{go_current_rowset_err} } );
+ $sth->finish; # no more data so finish
+ return $resultset;
+ }
+
+
+ sub rows {
+ return shift->{go_rows};
+ }
+
+
+ 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 could perhaps do
+ # XXX? push @{ $sth->{go_method_calls} }, [ 'STORE', $attrib, $value ];
+ Carp::carp("Can't alter \$sth->{$attrib}");
+ return $sth->set_err(1, "Can't alter \$sth->{$attrib}");
+ }
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBD::Gofer - A stateless-proxy driver for communicating with a remote DBI
+
+=head1 SYNOPSIS
+
+ use DBI;
+
+ $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$dsn",
+ $user, $passwd, \%attributes);
+
+The C<transport=$transport> part specifies the name of the module to use to
+transport the requests to the remote DBI. If $transport doesn't contain any
+double colons then it's prefixed with C<DBD::Gofer::Transport::>.
+
+The C<dsn=$dsn> part I<must> be the last element of the dsn because everything
+after C<dsn=> is assumed to be the DSN that the remote DBI should use.
+
+The C<...> represents attributes that influence the operation of the driver or
+transport. These are described below or in the documentation of the transport
+module being used.
+
+=head1 DESCRIPTION
+
+DBD::Gofer is a DBI database driver that forwards requests to another DBI
driver,
+usually in a seperate process, often on a separate machine.
+
+It is very similar to DBD::Proxy. The major difference is that DBD::Gofer
+assumes no state is maintained on the remote end. What does that mean?
+It means that every request contains all the information needed to create the
+required state. (So, for example, every request includes the DSN to connect
to.)
+Each request can be sent to any available server. The server executes
+the request and returns a single response that includes all the data.
+
+This is very similar to the way http works as a stateless protocol for the web.
+Each request from your web browser can be handled by a different web server
process.
+
+This may seem like pointless overhead but there are situations where this is a
+very good thing. Let's consider a specific case.
+
+Imagine using DBD::Gofer with an http transport. Your application calls
+connect(), prepare("select * from table where foo=?"), bind_param(), and
execute().
+At this point DBD::Gofer builds a request containing all the information
+about the method calls. It then uses the httpd transport to send that request
+to an apache web server.
+
+This 'dbi execute' web server executes the request (using DBI::Gofer::Execute
+and related modules) and builds a response that contains all the rows of data,
+if the statement returned any, along with all the attributes that describe the
+results, such as $sth->{NAME}. This response is sent back to DBD::Gofer which
+unpacks it and presents it to the application as if it had executed the
+statement itself.
+
+Okay, but you still don't see the point? Well let's consider what we've gained:
+
+=head3 Connection Pooling and Throttling
+
+The 'dbi execute' web server leverages all the functionality of web
+infrastructure in terms of load balancing, high-availability, firewalls, access
+management, proxying, caching.
+
+At it's most basic level you get a configurable pool of persistent database
connections.
+
+=head3 Simple Scaling
+
+Got thousands of processes all trying to connect to the database? You can use
+DBD::Gofer to connect them to your pool of 'dbi execute' web servers instead.
+
+=head3 Caching
+
+Not yet implemented, but the single request-response architecture lends itself
to caching.
+
+=head3 Fewer Network Round-trips
+
+DBD::Gofer sends as few requests as possible.
+
+=head3 Thin Clients / Unsupported Platforms
+
+You no longer need drivers for your database on every system.
+DBD::Gofer is pure perl
+
+=head1 CONSTRAINTS
+
+There are naturally a some constraints imposed by DBD::Gofer. But not many:
+
+=head2 You can't change database handle attributes
+
+You can't change database handle attributes after you've connected.
+Use the connect() call to specify all the attribute settings you want.
+
+This is because it's critical that when a request is complete the database
+handle is left in the same state it was when first connected.
+
+=head2 AutoCommit only
+
+Transactions aren't supported.
+
+=head1 CAVEATS
+
+A few things to keep in mind when using DBD::Gofer:
+
+=head2 Driver-private Methods
+
+These can be called via the func() method on the dbh
+but not the sth.
+
+=head2 Driver-private Statement Handle Attributes
+
+Driver-private sth attributes can be set in the prepare() call. XXX
+
+Driver-private sth attributes can't be read, currently. In future it will be
+possible to indicate which sth attributes you'd like to be able to read.
+
+=head1 Array Methods
+
+The array methods (bind_param_inout bind_param_array bind_param_inout_array
execute_array execute_for_fetch)
+are not currently supported. Patches welcome, of course.
+
+=head1 Multiple Resultsets
+
+Multiple resultsets are supported if the driver supports the more_results()
method.
+
+=head1 CONNECTING
+
+XXX
+
+=head2 Using DBI_AUTOPROXY
+
+XXX
+
+=head1 CONFIGURING VIA POLICY
+
+XXX
+
+=head1 AUTHOR AND COPYRIGHT
+
+The DBI module is 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.
+
+=head1 SEE ALSO
+
+L<DBD::Gofer::Request>, L<DBD::Gofer::Response>,
L<DBD::Gofer::Transport::Base>,
+
+L<DBI>, L<DBI::Gofer::Execute>.
+
+
+=head1 TODO
+
+dbh STORE doesn't record set attributes
+
+Driver-private sth attributes - set via prepare() - change DBI spec
+Auto-configure based on driver name.
+Automatically send back everything in sth attribute cache?
+
+Caching of get_info values
+
+prepare vs prepare_cached
+
+Driver-private sth methods via func? Can't be sure of state?
+
+Sybase specific features.
+
+XXX track installed_methods and install proxies on client side after connect?
+
+XXX add hooks into transport base class for checking & updating a cache
+ ie via a standard cache interface such as:
+ http://search.cpan.org/~robm/Cache-FastMmap/FastMmap.pm
+ http://search.cpan.org/~bradfitz/Cache-Memcached/lib/Cache/Memcached.pm
+ http://search.cpan.org/~dclinton/Cache-Cache/
+ http://search.cpan.org/~cleishman/Cache/
+
+Also caching instructions could be passed through the httpd transport layer
+in such a way that appropriate http cache headers are added to the results
+so that web caches (squid etc) could be used to implement the caching.
+(May require the use of GET rather than POST requests.)
+
+check clone tests
+
+add early test that connected dbh is active
+
+=cut
Added: dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Transport/Base.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,52 @@
+package DBD::Gofer::Transport::Base;
+
+# $Id: Base.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 qw(cluck);
+use Storable qw(freeze thaw);
+
+use base qw(Class::Accessor::Fast);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+our $debug = $ENV{DBD_GOFER_TRACE} || 0;
+
+
+__PACKAGE__->mk_accessors(qw(
+ go_dsn
+));
+
+
+sub freeze_data {
+ my ($self, $data, $skip_debug) = @_;
+ $self->_dump("DBD_GOFER_TRACE freezing ".ref($data), $data)
+ if $debug && not $skip_debug;
+ local $Storable::forgive_me = 1; # for CODE refs etc
+ return freeze($data);
+}
+
+sub thaw_data {
+ my ($self, $frozen_data, $skip_debug) = @_;
+ my $data = thaw($frozen_data);
+ $self->_dump("DBD_GOFER_TRACE thawing ".ref($data), $data)
+ if $debug && not $skip_debug;
+ return $data;
+}
+
+
+sub _dump {
+ my ($self, $label, $data) = @_;
+ require Data::Dumper;
+ # XXX dd settings
+ warn "$label=".Data::Dumper::Dumper($data);
+}
+
+1;
Added: dbi/trunk/lib/DBD/Gofer/Transport/null.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Gofer/Transport/null.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,67 @@
+package DBD::Gofer::Transport::null;
+
+# $Id: null.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 base qw(DBD::Gofer::Transport::Base);
+
+use DBI::Gofer::Execute qw(execute_request);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+__PACKAGE__->mk_accessors(qw(
+ pending_response
+));
+
+
+sub transmit_request {
+ my ($self, $request) = @_;
+
+ my $frozen_request = $self->freeze_data($request);
+
+ # ...
+ # the request is magically transported over to ... ourselves
+ # ...
+
+ # since we're in the same process, we don't want to show the DBI trace
+ # enabled for the 'client' because it gets very hard to follow.
+ # So control the Gofer 'server' side independently
+ # but similar logic as used for DBI_TRACE parsing.
+ my $prev_trace_level = DBI->trace(
+ ($ENV{DBD_GOFER_NULL_TRACE}) ? (split /=/, $ENV{DBD_GOFER_NULL_TRACE})
: (0)
+ );
+
+ my $response = execute_request( $self->thaw_data($frozen_request,1) );
+
+ DBI->trace($prev_trace_level);
+
+ # put response 'on the shelf' ready for receive_response()
+ $self->pending_response( $response );
+
+ return 1;
+}
+
+
+sub receive_response {
+ my $self = shift;
+
+ my $response = $self->pending_response;
+
+ my $frozen_response = $self->freeze_data($response,1);
+
+ # ...
+ # the response is magically transported back to ... ourselves
+ # ...
+
+ return $self->thaw_data($frozen_response);
+}
+
+
+1;
Added: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,215 @@
+package DBI::Gofer::Execute;
+
+# $Id: Execute.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 DBI;
+use DBI::Gofer::Request;
+use DBI::Gofer::Response;
+
+use base qw(Exporter);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+our @EXPORT_OK = qw(
+ execute_request
+ execute_dbh_request
+ execute_sth_request
+);
+
+our @sth_std_attr = qw(
+ NUM_OF_PARAMS
+ NUM_OF_FIELDS
+ NAME
+ TYPE
+ NULLABLE
+ PRECISION
+ SCALE
+ CursorName
+);
+
+our $trace = $ENV{DBI_GOFER_TRACE};
+
+our $recurse = 0;
+
+# XXX tracing
+
+sub _connect {
+ my $request = shift;
+ local $ENV{DBI_AUTOPROXY};
+ my $connect_args = $request->connect_args;
+ my ($dsn, $u, $p, $attr) = @$connect_args;
+ # delete attributes we don't want to affect the server-side
+ delete @{$attr}{qw(Profile InactiveDestroy Warn HandleError HandleSetErr
TraceLevel Taint TaintIn TaintOut)};
+ my $connect_method = 'connect_cached';
+#$connect_method = 'connect';
+ # XXX need way to limit/purge connect cache over time
+ my $dbh = DBI->$connect_method($dsn, $u, $p, {
+ %$attr,
+ # force some attributes the way we want them
+ PrintWarn => 0,
+ PrintError => 0,
+ RaiseError => 1,
+ # ensure this connect_cached doesn't have the same args as the client
+ # because that causes subtle issues if in the same process (ie
transport=null)
+ dbi_go_execute_unique => 42+$recurse+rand(),
+ });
+ die "NOT CONNECTED" if $dbh and not $dbh->{Active};
+ #$dbh->trace(0);
+ return $dbh;
+}
+
+
+sub _reset_dbh {
+ my ($dbh) = @_;
+ $dbh->set_err(undef, undef); # clear any error state
+ #$dbh->trace(0, \*STDERR);
+}
+
+
+sub _new_response_with_err {
+ my ($rv) = @_;
+
+ my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
+ if ($@ and !$errstr || $@ !~ /^DBD::/) {
+ $err ||= 1;
+ $errstr = ($errstr) ? "$errstr; $@" : $@;
+ }
+ my $response = DBI::Gofer::Response->new({
+ rv => $rv,
+ err => $err,
+ errstr => $errstr,
+ state => $state,
+ });
+ return $response;
+}
+
+
+sub execute_request {
+ my $request = shift;
+ local $recurse = $recurse + 1;
+ warn "Gofer request level $recurse\n" if $trace;
+ # guaranteed not to throw an exception
+ my $response = eval {
+ ($request->is_sth_request)
+ ? execute_sth_request($request)
+ : execute_dbh_request($request);
+ };
+ if ($@) {
+ warn $@; # XXX
+ chomp $@;
+ $response = DBI::Gofer::Response->new({
+ err => 1, errstr => $@, state => '',
+ });
+ }
+ warn "Gofer response level $recurse: ".$response->rv."\n" if $trace;
+ return $response;
+}
+
+sub execute_dbh_request {
+ my $request = shift;
+ my $dbh;
+ my $rv_ref = eval {
+ $dbh = _connect($request);
+ my $meth = $request->dbh_method_name;
+ my $args = $request->dbh_method_args;
+ my @rv = ($request->dbh_wantarray)
+ ? $dbh->$meth(@$args)
+ : scalar $dbh->$meth(@$args);
+ [EMAIL PROTECTED];
+ };
+ 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_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)");
+ }
+ if (0) {
+ # if not using connect_cached then we want to gracefu
+ local $SIG{__WARN__} = sub {};
+ undef $dbh;
+ }
+ return $response;
+}
+
+
+sub execute_sth_request {
+ my $request = shift;
+ my $dbh;
+ my $sth;
+
+ my $rv = eval {
+ $dbh = _connect($request);
+
+ 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;
+ $last = $sth->$method(@$meth_call);
+ }
+ $last;
+ };
+ my $response = _new_response_with_err($rv);
+
+ # 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 = [];
+ do {
+ my $rs = fetch_result_set($sth, $attr_list);
+ push @$rs_list, $rs;
+ } while $sth->more_results;
+
+ $rs_list;
+ };
+}
+
+
+sub fetch_result_set {
+ my ($sth, $extra_attr) = @_;
+ my %meta;
+ for my $attr (@sth_std_attr, @$extra_attr) {
+ $meta{ $attr } = $sth->{$attr};
+ }
+ if ($sth->FETCH('NUM_OF_FIELDS')) { # if a select
+ $meta{rowset} = eval { $sth->fetchall_arrayref() };
+ $meta{err} = $DBI::err;
+ $meta{errstr} = $DBI::errstr;
+ $meta{state} = $DBI::state;
+ }
+ return \%meta;
+}
+
+1;
Added: dbi/trunk/lib/DBI/Gofer/Request.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Gofer/Request.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,43 @@
+package DBI::Gofer::Request;
+
+# $Id: Request.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 base qw(Class::Accessor::Fast);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+
+__PACKAGE__->mk_accessors(qw(
+ connect_args
+ dbh_method_name
+ dbh_method_args
+ dbh_wantarray
+ dbh_last_insert_id_args
+ sth_method_calls
+ sth_result_attr
+));
+
+sub reset {
+ my $self = shift;
+ # remove everything except connect
+ %$self = ( connect_args => $self->{connect_args} );
+}
+
+sub is_sth_request {
+ return shift->{sth_result_attr};
+}
+
+sub init_request {
+ my ($self, $method, $args_ref, $wantarray) = @_;
+ $self->reset;
+ $self->dbh_method_name($method);
+ $self->dbh_method_args($args_ref);
+ $self->dbh_wantarray($wantarray);
+}
+
+1;
Added: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,23 @@
+package DBI::Gofer::Response;
+
+# $Id: Response.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 base qw(Class::Accessor::Fast);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+__PACKAGE__->mk_accessors(qw(
+ rv
+ err
+ errstr
+ state
+ last_insert_id
+ sth_resultsets
+));
+
+1;
Added: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm Mon Jan 29 05:21:16 2007
@@ -0,0 +1,48 @@
+package DBD::Gofer::Transport::Base;
+
+# $Id: Base.pm 8696 2007-01-24 23:12:38Z timbo $
+#
+# 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 Storable qw(freeze thaw);
+
+use base qw(Class::Accessor::Fast);
+
+our $VERSION = sprintf("0.%06d", q$Revision: 8696 $ =~ /(\d+)/o);
+
+our $debug = $ENV{DBI_GOFER_TRACE} || 0;
+
+
+__PACKAGE__->mk_accessors(qw(
+ go_dsn
+));
+
+
+sub freeze_data {
+ my ($self, $data) = @_;
+ $self->_dump("DBI_GOFER_TRACE ".ref($data), $data) if $debug;
+ local $Storable::forgive_me = 1; # for CODE refs etc
+ return freeze($data);
+}
+
+sub thaw_data {
+ my ($self, $frozen_data) = @_;
+ my $data = thaw($frozen_data);
+ $self->_dump("DBI_GOFER_TRACE ".ref($data), $data) if $debug;
+ return $data;
+}
+
+
+sub _dump {
+ my ($self, $label, $data) = @_;
+ require Data::Dumper;
+ warn "$label=".Dumper($request);
+}
+
+1;
Added: dbi/trunk/t/85gofer.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/85gofer.t Mon Jan 29 05:21:16 2007
@@ -0,0 +1,69 @@
+#!perl -w # -*- perl -*-
+# vim:sw=4:ts=8
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use DBI;
+
+use lib "/Users/timbo/dbi/trunk/lib";
+
+# use DBD::Gofer directly.
+# when combined with DBI_AUTOPROXY this means we have DBD::Gofer => DBD::Gofer
=> DBD::DBM!
+#
+my $dsn = "dbi:Gofer:transport=null;dsn=dbi:DBM:dbm_type=SDBM_File;lockfile=0";
+my $dbh = DBI->connect($dsn);
+ok $dbh, 'should connect';
+
+
+ # 0=SQL::Statement if avail, 1=DBI::SQL::Nano
+ # next line forces use of Nano rather than default behaviour
+ $ENV{DBI_SQL_NANO}=1;
+
+#my $dir = './test_output';
+#rmtree $dir;
+#mkpath $dir;
+
+my @sql = split /\s*;\n/, join '',<DATA>;
+
+for my $sql ( @sql ) {
+ $sql =~ s/;$//; # in case no final \n on last line of __DATA__
+ my $null = '';
+ my $expected_results = {
+ 1 => 'oranges',
+ 2 => 'apples',
+ 3 => $null,
+ };
+ if ($sql !~ /SELECT/) {
+ print " do $sql\n";
+ $dbh->do($sql) or die $dbh->errstr;
+ next;
+ }
+ print " run $sql\n";
+ my $sth = $dbh->prepare($sql) or die $dbh->errstr;
+ $sth->execute;
+ die $sth->errstr if $sth->err and $sql !~ /DROP/;
+ # Note that we can't rely on the order here, it's not portable,
+ # different DBMs (or versions) will return different orders.
+ while (my ($key, $value) = $sth->fetchrow_array) {
+ ok exists $expected_results->{$key};
+ is $value, $expected_results->{$key};
+ }
+ is $DBI::rows, keys %$expected_results;
+}
+$dbh->disconnect;
+
+1;
+__DATA__
+DROP TABLE IF EXISTS fruit;
+CREATE TABLE fruit (dKey INT, dVal VARCHAR(10));
+INSERT INTO fruit VALUES (1,'oranges' );
+INSERT INTO fruit VALUES (2,'to_change' );
+INSERT INTO fruit VALUES (3, NULL );
+INSERT INTO fruit VALUES (4,'to delete' );
+UPDATE fruit SET dVal='apples' WHERE dKey=2;
+DELETE FROM fruit WHERE dVal='to delete';
+SELECT * FROM fruit;
+DROP TABLE fruit;
