Author: timbo
Date: Fri Jan 19 10:13:30 2007
New Revision: 8622
Added:
dbi/trunk/lib/DBD/Forward.pm
dbi/trunk/lib/DBI/Forward/
dbi/trunk/lib/DBI/Forward/Execute.pm
dbi/trunk/lib/DBI/Forward/Request.pm
dbi/trunk/lib/DBI/Forward/Response.pm
dbi/trunk/lib/DBI/Forward/Transport/
dbi/trunk/lib/DBI/Forward/Transport/Base.pm
dbi/trunk/lib/DBI/Forward/Transport/null.pm
dbi/trunk/t/85forward.t
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
Log:
First reasonably-working version of DBD::Forward (stateless proxy)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Fri Jan 19 10:13:30 2007
@@ -4,6 +4,8 @@
=cut
+XXX document DBD::Forward
+
=head2 Changes in DBI 1.XX (svn rev XX), XX
Fixed type_info when called for multiple dbh thanks to Cosimo Streppone.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Fri Jan 19 10:13:30 2007
@@ -319,6 +319,7 @@
df_ => { class => 'DBD::DF', },
f_ => { class => 'DBD::File', },
file_ => { class => 'DBD::TextFile', },
+ fwd_ => { class => 'DBD::Forward', },
ib_ => { class => 'DBD::InterBase', },
ing_ => { class => 'DBD::Ingres', },
ix_ => { class => 'DBD::Informix', },
@@ -3376,7 +3377,7 @@
driver handle, returns a reference to the cache (hash) of
database handles created by the L</connect_cached> method.
-=item C<Type> (scalar)
+=item C<Type> (scalar, read-only)
The C<Type> attribute identifies the type of a DBI handle. Returns
"dr" for driver handles, "db" for database handles and "st" for
Added: dbi/trunk/lib/DBD/Forward.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBD/Forward.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,325 @@
+{
+ package DBD::Forward;
+
+ use strict;
+
+ require DBI;
+ require DBI::Forward::Request;
+ require DBI::Forward::Response;
+ require Carp;
+
+ our $VERSION = sprintf("%d.%02d", q$Revision: 11.4 $ =~ /(\d+)\.(\d+)/o);
+
+# $Id: Forward.pm 2488 2006-02-07 22:24:43Z 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
+ ErrCount Executed
+ FetchHashKeyName
+ HandleError HandleSetErr
+ InactiveDestroy
+ PrintError PrintWarn
+ Profile
+ RaiseError
+ ShowErrorStatement
+ Taint TaintIn TaintOut
+ TraceLevel
+ Warn
+ );
+
+ our $drh = undef; # holds driver handle once initialised
+
+ sub driver{
+ return $drh if $drh;
+
+ DBI->setup_driver('DBD::Forward');
+
+ DBD::Forward::db->install_method('fwd_dbh_method', { O=> 0x0004 }); #
IMA_KEEP_ERR
+
+ my($class, $attr) = @_;
+ $class .= "::dr";
+ ($drh) = DBI::_new_drh($class, {
+ 'Name' => 'Forward',
+ 'Version' => $VERSION,
+ 'Attribution' => 'DBD Forward by Tim Bunce',
+ });
+
+ $drh;
+ }
+
+ sub CLONE {
+ undef $drh;
+ }
+
+}
+
+
+{ package DBD::Forward::dr; # ====== DRIVER ======
+
+ my %dsn_attr_defaults = (
+ fwd_dsn => undef,
+ fwd_url => undef,
+ fwd_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 $fwd_dsn = ($dsn =~ s/\bdsn=(.*)$// && $1)
+ or return $drh->set_err(1, "No dsn= argument in '$orig_dsn'");
+
+ my %dsn_attr = (%dsn_attr_defaults, fwd_dsn => $fwd_dsn);
+ # extract fwd_ attributes
+ for my $k (grep { /^fwd_/ } keys %$attr) {
+ $dsn_attr{$k} = delete $attr->{$k};
+ }
+ # then override with attributes embedded in dsn
+ for my $kv (grep /=/, split /;/, $dsn, -1) {
+ my ($k, $v) = split /=/, $kv, 2;
+ $dsn_attr{ "fwd_$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{fwd_transport}
+ or return $drh->set_err(1, "No transport= argument in
'$orig_dsn'");
+ $transport_class = "DBI::Forward::Transport::$dsn_attr{fwd_transport}"
+ unless $transport_class =~ /::/;
+ eval "require $transport_class"
+ or return $drh->set_err(1, "Error loading $transport_class: $@");
+ my $fwd_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::Forward::Request";
+ my $fwd_request = eval {
+ $request_class->new({
+ connect_args => [ $fwd_dsn, $user, $auth, $attr ]
+ })
+ } or return $drh->set_err(1, "Error instanciating $request_class $@");
+
+ my ($dbh, $dbh_inner) = DBI::_new_dbh($drh, {
+ 'Name' => $dsn,
+ 'USER' => $user,
+ fwd_trans => $fwd_trans,
+ fwd_request => $fwd_request,
+ });
+
+ # store and delete the attributes before marking connection Active
+ $dbh->STORE($_ => delete $attr->{$_}) for keys %$attr;
+
+ $dbh->STORE(Active => 1);
+
+ return $dbh;
+ }
+
+ sub DESTROY { undef }
+}
+
+
+{ package DBD::Forward::db; # ====== DATABASE ======
+ $imp_data_size = 0;
+ use strict;
+ use Carp qw(croak);
+
+ my %dbh_local_store_attrib = %DBD::Forward::xxh_local_store_attrib;
+
+ sub fwd_dbh_method {
+ my ($dbh, $method, $meta, @args) = @_;
+ $dbh->trace_msg(" fwd_dbh_method($dbh, $method, @args)\n");
+ my $request = $dbh->{fwd_request};
+ $request->init_request($method, [EMAIL PROTECTED], wantarray);
+
+ my $response = $dbh->{fwd_trans}->execute($request);
+
+ $dbh->{fwd_response} = $response;
+
+ $dbh->set_err($response->err, $response->errstr, $response->state);
+ #$dbh->rows($response->rows); # can't, and not needed?
+ my $rv = $response->rv;
+ return (wantarray) ? @$rv : $rv->[0];
+ }
+
+ # Methods that should be forwarded
+ # XXX ping? local or remote - add policy attribute
+ # XXX get_info? special sub to lazy-cache individual values
+ for my $method (qw(
+ do data_sources
+ table_info column_info primary_key_info foreign_key_info
statistics_info
+ type_info_all get_info
+ ping
+ )) {
+ no strict 'refs';
+ *$method = sub { return shift->fwd_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") }
+ }
+
+ # for quote we rely on the default method + type_info_all
+ # for quote_identifier we rely on the default method + get_info
+
+ sub last_insert_id {
+ my $dbh = shift;
+ my $response = $dbh->{fwd_response} or return undef;
+ # will be undef unless last_insert_id was explicitly requested
+ return $response->last_insert_id;
+ }
+
+ sub FETCH {
+ my ($dbh, $attrib) = @_;
+ # AutoCommit needs special handling
+ return 1 if $attrib eq 'AutoCommit';
+ # else pass up to DBI to handle
+ return $dbh->SUPER::FETCH($attrib);
+ }
+
+ sub STORE {
+ my ($dbh, $attrib, $value) = @_;
+ if ($attrib eq 'AutoCommit') {
+ return 1 if $value;
+ croak "Can't enable transactions when using DBD::Forward";
+ }
+ return $dbh->SUPER::STORE($attrib => $value)
+ if $dbh_local_store_attrib{$attrib} # handle locally
+ or $attrib =~ m/^[a-z]/ # driver-private
+ or not $dbh->FETCH('Active'); # not yet connected
+
+ # ignore values that aren't actually being changed
+ my $prev = $dbh->FETCH($attrib);
+ return 1 if !defined $value && !defined $prev
+ or defined $value && defined $prev && $value eq $prev;
+
+ # 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 {
+ # XXX discard state for dbh and destroy child handles
+ shift->STORE(Active => 0);
+ }
+
+ sub prepare {
+ my ($dbh, $statement, $attr)= @_;
+
+ return $dbh->set_err(1, "Can't prepare when disconnected")
+ unless $dbh->FETCH('Active');
+
+ my ($outer, $sth) = DBI::_new_sth($dbh, {
+ Statement => $statement,
+ fwd_prepare_args => [ $statement, $attr ],
+ fwd_method_calls => [],
+ fwd_request => $dbh->{fwd_request},
+ fwd_trans => $dbh->{fwd_trans},
+ });
+
+ $outer;
+ }
+
+}
+
+
+{ package DBD::Forward::st; # ====== STATEMENT ======
+ $imp_data_size = 0;
+ use strict;
+
+ sub execute {
+ my($sth, @bind) = @_;
+
+ # XXX validate that @bind==NUM_OFPARAM
+ $sth->bind_param($_, $bind[$_-1]) for ([EMAIL PROTECTED]);
+
+ my $request = $sth->{fwd_request};
+ $request->init_request('prepare', $sth->{fwd_prepare_args}, undef);
+ $request->sth_method_calls($sth->{fwd_method_calls});
+ $request->sth_result_attr({});
+
+ my $response = $sth->{fwd_trans}->execute($request);
+
+ $sth->{fwd_response} = $response;
+ $sth->{fwd_method_calls} = [];
+
+ # setup first resultset
+ $sth->more_results if $response->sth_resultsets;
+
+ $sth->set_err($response->err, $response->errstr, $response->state);
+ return $response->rv;
+ }
+
+
+ # 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") }
+ }
+
+
+ sub bind_param {
+ my ($sth, $param, $value, $attr) = @_;
+ $sth->{ParamValues}{$param} = $value;
+ push @{ $sth->{fwd_method_calls} }, [ 'bind_param', $param, $value,
$attr ];
+ return 1;
+ }
+
+ sub fetchrow_arrayref {
+ my ($sth) = @_;
+ my $resultset = $sth->{fwd_current_resultset}
+ or return $sth->set_err(1, "No result set available");
+ return shift @$resultset if @$resultset;
+ $sth->finish; # no more data so finish
+ return undef;
+ }
+ *fetch = \&fetchrow_arrayref; # alias
+
+ sub more_results {
+ my ($sth) = @_;
+ $sth->finish if $sth->FETCH('Active');
+ my $resultset_list = $sth->{fwd_response}->sth_resultsets
+ or return $sth->set_err(1, "No sth_resultsets");
+ return undef unless @$resultset_list;
+ my $meta = shift @$resultset_list
+ or return undef; # no more result sets
+ $sth->{fwd_current_resultset} = delete $meta->{rowset}
+ or return $sth->set_err(1, "No rowset in meta");
+ # copy meta attributes into attribute cache
+ $sth->{$_} = $meta->{$_} for keys %$meta;
+ return $sth;
+ }
+
+ sub rows {
+ my $sth = shift;
+ my $response = $sth->{fwd_response} or return -1;
+ return $response->rv;
+ }
+
+ sub STORE {
+ my ($sth, $attrib, $value) = @_;
+ DBD::Forward::_note_attrib_store($sth, $attrib, $value);
+ return $sth->SUPER::STORE($attrib, $value);
+ }
+
+}
+
+1;
Added: dbi/trunk/lib/DBI/Forward/Execute.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Forward/Execute.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,133 @@
+package DBI::Forward::Execute;
+
+use strict;
+use warnings;
+
+use DBI;
+use DBI::Forward::Request;
+use DBI::Forward::Response;
+
+use base qw(Exporter);
+
+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
+);
+
+sub _connect {
+ my $request = shift;
+ my $connect_args = $request->connect_args;
+ my ($dsn, $u, $p, $attr) = @$connect_args;
+ # XXX need way to limit/purge connect cache over time
+ my $dbh = DBI->connect_cached($dsn, $u, $p, {
+ %$attr,
+ # override some attributes
+ PrintWarn => 0,
+ PrintError => 0,
+ RaiseError => 1,
+ });
+ # $dbh->trace(2);
+ return $dbh;
+}
+
+sub execute_request {
+ my $request = shift;
+ my $response = eval {
+ ($request->is_sth_request)
+ ? execute_sth_request($request)
+ : execute_dbh_request($request);
+ };
+ if ($@) {
+ warn $@; # XXX
+ $response = DBI::Forward::Response->new({
+ err => 1, errstr => $@, state => '',
+ });
+ }
+ return $response;
+}
+
+sub execute_dbh_request {
+ my $request = shift;
+ my $dbh;
+ my $rv = 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 = DBI::Forward::Response->new({
+ rv => $rv,
+ err => $DBI::err,
+ errstr => $DBI::errstr,
+ state => $DBI::state,
+ });
+ $response->last_insert_id = $dbh->last_insert_id( @{
$request->dbh_last_insert_id_args })
+ if $dbh && $rv && $request->dbh_last_insert_id_args;
+ return $response;
+}
+
+sub execute_sth_request {
+ my $request = shift;
+ my $dbh;
+ my $rv;
+ my $resultset_list = eval {
+ $dbh = _connect($request);
+
+ my $meth = $request->dbh_method_name;
+ my $args = $request->dbh_method_args;
+ my $sth = $dbh->$meth(@$args);
+
+ for my $meth_call (@{ $request->sth_method_calls }) {
+ my $method = shift @$meth_call;
+ $sth->$method(@$meth_call);
+ }
+
+ $rv = $sth->execute();
+
+ 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;
+ };
+ my $response = DBI::Forward::Response->new({
+ rv => $rv,
+ err => $DBI::err,
+ errstr => $DBI::errstr,
+ state => $DBI::state,
+ sth_resultsets => $resultset_list,
+ });
+
+ return $response;
+}
+
+sub fetch_result_set {
+ my ($sth, $extra_attr) = @_;
+ my %meta;
+ for my $attr (@sth_std_attr, @$extra_attr) {
+ $meta{ $attr } = $sth->{$attr};
+ }
+ $meta{rowset} = $sth->fetchall_arrayref();
+ return \%meta;
+}
+
+1;
Added: dbi/trunk/lib/DBI/Forward/Request.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Forward/Request.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,33 @@
+package DBI::Forward::Request;
+
+use base qw(Class::Accessor::Fast);
+
+__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/Forward/Response.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Forward/Response.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,14 @@
+package DBI::Forward::Response;
+
+use base qw(Class::Accessor::Fast);
+
+__PACKAGE__->mk_accessors(qw(
+ rv
+ err
+ errstr
+ state
+ last_insert_id
+ sth_resultsets
+));
+
+1;
Added: dbi/trunk/lib/DBI/Forward/Transport/Base.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Forward/Transport/Base.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,20 @@
+package DBI::Forward::Transport::Base;
+
+use strict;
+use warnings;
+
+use Storable qw(freeze thaw);
+
+use base qw(Class::Accessor::Fast);
+
+__PACKAGE__->mk_accessors(qw(
+ fwd_dsn
+));
+
+sub execute {
+ my ($self, $request) = @_;
+ die ref($self)." has not implemented a transport method";
+}
+
+
+1;
Added: dbi/trunk/lib/DBI/Forward/Transport/null.pm
==============================================================================
--- (empty file)
+++ dbi/trunk/lib/DBI/Forward/Transport/null.pm Fri Jan 19 10:13:30 2007
@@ -0,0 +1,33 @@
+package DBI::Forward::Transport::null;
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+
+our $debug = 0;
+
+use Storable qw(freeze thaw);
+
+use DBI::Forward::Execute qw(execute_request);
+
+use base qw(DBI::Forward::Transport::Base);
+
+sub execute {
+ my ($self, $request) = @_;
+ warn "REQUEST=".Dumper($request) if $debug;
+ my $frozen_request = freeze($request);
+ # ...
+ # the request is magically transported over to ... ourselves
+ # ...
+ my $response = execute_request( thaw $frozen_request );
+ warn "RESPONSE=".Dumper($response) if $debug;
+ my $frozen_response = freeze($response);
+ # ...
+ # the response is magically transported back to ... ourselves
+ # ...
+ return thaw($frozen_response);
+}
+
+
+1;
Added: dbi/trunk/t/85forward.t
==============================================================================
--- (empty file)
+++ dbi/trunk/t/85forward.t Fri Jan 19 10:13:30 2007
@@ -0,0 +1,66 @@
+#!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";
+
+my $dsn =
"dbi:Forward: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;
