Author: timbo
Date: Mon Feb 12 05:34:03 2007
New Revision: 9082
Modified:
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
Log:
Add initial dir_config configuration support for mod_perl transport.
Make DBI::Gofer::Export more OO.
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Mon Feb 12 05:34:03 2007
@@ -11,6 +11,7 @@
use warnings;
use DBI;
+use DBI::Gofer::Request;
use DBI::Gofer::Response;
use base qw(DBI::Util::_accessor);
@@ -81,16 +82,14 @@
sub _connect {
- my $request = shift;
+ my ($self, $request) = @_;
local $ENV{DBI_AUTOPROXY}; # limit the insanity
- my $connect_args = $request->connect_args;
- my ($dsn, $u, $p, $attr) = @$connect_args;
+ my ($dsn, $u, $p, $attr) = @{ $request->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, {
@@ -101,31 +100,32 @@
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 => rand(),
+ dbi_go_execute_unique => __PACKAGE__,
});
- die "NOT CONNECTED" if $dbh and not $dbh->{Active};
#$dbh->trace(0);
return $dbh;
}
-sub _reset_dbh {
- my ($dbh) = @_;
+sub reset_dbh {
+ my ($self, $dbh) = @_;
$dbh->set_err(undef, undef); # clear any error state
}
-sub _new_response_with_err {
- my ($rv) = @_;
+sub new_response_with_err {
+ my ($self, $rv, $eval_error) = @_;
+ # capture err+errstr etc and merge in $eval_error ($@)
my ($err, $errstr, $state) = ($DBI::err, $DBI::errstr, $DBI::state);
# if we caught an exception and there's either no DBI error, or the
# exception itself doesn't look like a DBI exception, then append the
# exception to errstr
- if ($@ and !$errstr || $@ !~ /^DBD::/) {
+ if ($eval_error and (!$errstr || $eval_error !~ /^DBD::/)) {
+ chomp $eval_error;
$err ||= 1;
- $errstr = ($errstr) ? "$errstr; $@" : $@;
+ $errstr = ($errstr) ? "$errstr; $eval_error" : $eval_error;
}
my $response = DBI::Gofer::Response->new({
@@ -141,21 +141,16 @@
sub execute_request {
my ($self, $request) = @_;
- DBI->trace_msg("-----> execute_request\n");
+ # should never throw an exception
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_ };
- # guaranteed not to throw an exception
+ DBI->trace_msg("-----> execute_request\n");
my $response = eval {
($request->is_sth_request)
- ? execute_sth_request($request)
- : execute_dbh_request($request);
+ ? $self->execute_sth_request($request)
+ : $self->execute_dbh_request($request);
};
- if ($@) {
- chomp $@;
- $response = DBI::Gofer::Response->new({
- err => 1, errstr => $@, state => '',
- });
- }
+ $response = $self->new_response_with_err(undef, $@) if $@;
$response->warnings([EMAIL PROTECTED]) if @warnings;
DBI->trace_msg("<----- execute_request\n");
return $response;
@@ -163,10 +158,10 @@
sub execute_dbh_request {
- my $request = shift;
+ my ($self, $request) = @_;
my $dbh;
my $rv_ref = eval {
- $dbh = _connect($request);
+ $dbh = $self->_connect($request);
my $meth = $request->dbh_method_name;
my $args = $request->dbh_method_args;
my @rv = ($request->dbh_wantarray)
@@ -174,35 +169,35 @@
: scalar $dbh->$meth(@$args);
[EMAIL PROTECTED];
};
- my $response = _new_response_with_err($rv_ref);
+ 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;
- _reset_dbh($dbh);
+ $self->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)");
+ my $rv = $rv_ref->[0];
+ $response->sth_resultsets( $self->gather_sth_resultsets($rv, $request)
);
+ $response->rv("(sth)"); # don't try to return actual sth
}
return $response;
}
sub execute_sth_request {
- my $request = shift;
+ my ($self, $request) = @_;
my $dbh;
my $sth;
my $rv = eval {
- $dbh = _connect($request);
+ $dbh = $self->_connect($request);
my $meth = $request->dbh_method_name;
my $args = $request->dbh_method_args;
$sth = $dbh->$meth(@$args);
- my $last = '(sth)'; # a true value
+ 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 }) {
@@ -211,22 +206,22 @@
}
$last;
};
- my $response = _new_response_with_err($rv);
+ my $response = $self->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;
+ $response->sth_resultsets( $self->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;
+ $self->reset_dbh($dbh) if $dbh;
return $response;
}
-sub _gather_sth_resultsets {
- my ($sth, $request) = @_;
+sub gather_sth_resultsets {
+ my ($self, $sth, $request) = @_;
return eval {
my $driver_name = $sth->{Database}{Driver}{Name};
my $extra_sth_attr = $extra_attr{$driver_name}{sth} || [];
@@ -242,7 +237,7 @@
my $rs_list = [];
do {
- my $rs = fetch_result_set($sth, $sth_attr);
+ my $rs = $self->fetch_result_set($sth, $sth_attr);
push @$rs_list, $rs;
} while $sth->more_results
|| $sth->{syb_more_results};
@@ -253,7 +248,7 @@
sub fetch_result_set {
- my ($sth, $extra_sth_attr) = @_;
+ my ($self, $sth, $extra_sth_attr) = @_;
my %meta;
while ( my ($attr,$use) = each %$extra_sth_attr ) {
next unless $use;
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 Mon Feb 12 05:34:03 2007
@@ -12,21 +12,69 @@
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
my $transport = __PACKAGE__->new();
-my $executor = DBI::Gofer::Execute->new();
+my %executor_configs;
+my %executor_cache;
-sub handler {
+
+sub handler ($$) {
+ my $self = shift;
my $r = shift;
- my $r_dir_config = $r->dir_config; # cache it as it's relatively expensive
- $r->read(my $frozen_request, $r->header_in('Content-length'));
+ my $executor = $executor_cache{ $r->uri } ||= $self->executor_for_uri($r);
+ $r->read(my $frozen_request, $r->header_in('Content-length'));
my $request = $transport->thaw_data($frozen_request);
+
my $response = $executor->execute_request( $request );
my $frozen_response = $transport->freeze_data($response);
-
print $frozen_response;
return Apache::Constants::OK;
}
+
+
+sub executor_for_uri {
+ my ($self, $r) = @_;
+ my $uri = $r->uri;
+ my $r_dir_config = $r->dir_config;
+
+ my @location_configs = $r_dir_config->get('GoferConfig');
+ push @location_configs, 'default' unless @location_configs;
+
+ # merge all configs for this location in sequence ('closest' last)
+ my %merged_config;
+ for my $config_name ( @location_configs ) {
+ my $config = $executor_configs{$config_name};
+ if (!$config) {
+ # die if an unknown config is requested but not defined
+ # (don't die for 'default' unless it was explicitly requested)
+ die "$uri: GoferConfig '$config_name' not defined"
+ unless $config_name eq 'default'
+ and !$r_dir_config->get('GoferConfig');
+ next;
+ }
+ for my $type (qw(require default force)) {
+ my $type_config = $config->{$type};
+ next if !$type_config or !%$type_config;
+ warn "$uri: GoferConfig $config_name $type (@{[ %$type_config
]})\n";
+ my $merged = $merged_config{$type} ||= {};
+ $merged->{$_} = $type_config->{$_} for keys %$type_config;
+ }
+ }
+ my $executor = DBI::Gofer::Execute->new(\%merged_config);
+ return $executor;
+}
+
+
+sub configuration { # one-time setup from httpd.conf
+ my ($self, $configs) = @_;
+ %executor_configs = %$configs;
+}
+
+1;
+
+__END__
+
+also need a CGI/FastCGI transport
