Author: timbo
Date: Mon Feb 12 09:35:33 2007
New Revision: 9091
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/Gofer/Transport/mod_perl.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/lib/DBI/Util/_accessor.pm
dbi/trunk/t/10examp.t
dbi/trunk/t/50dbm.t
Log:
set_err won't duplicate an error message now.
Integrate gofer tracing into DBI tracing some more.
Make dir-sensitive tests use absolute dir so they'll work with gofer mod_perl.
Polish up gofer mod_perl config mechanism.
Handle Username and Password as attributes to integrate with gofer config.
Purge all cached dbh (and thus sth) from time-to-time (will config later).
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Feb 12 09:35:33 2007
@@ -31,6 +31,8 @@
to only be given for dbh that have active sth or are not AutoCommit.
Changed take_imp_data to call finish on all Active child sth.
Changed DBI::PurePerl trace() method to be more consistent.
+ Changed set_err method to effectively not append to errstr if the new errstr
+ is the same as the current one.
Changed handle factory methods, like connect, prepare, and table_info,
to copy any error/warn/info state of the handle being returned
up into the handle the method was called on.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Mon Feb 12 09:35:33 2007
@@ -3148,11 +3148,12 @@
Some special rules apply if the C<err> or C<errstr>
values for the handle are I<already> set...
-If C<errstr> is true then: "C< [err was %s now %s]>" is appended if
-$err is true and C<err> is already true; "C< [state was %s now %s]>"
-is appended if $state is true and C<state> is already true; then
-"C<\n>" and the new $errstr are appended. Obviously the C<%s>'s
-above are replaced by the corresponding values.
+If C<errstr> is true then: "C< [err was %s now %s]>" is appended if $err is
+true and C<err> is already true and the new err value differs from the original
+one. Similarly "C< [state was %s now %s]>" is appended if $state is true and
C<state> is
+already true and the new state value differs from the original one. Finally
+"C<\n>" and the new $errstr are appended if $errstr differs from the existing
+errstr value. Obviously the C<%s>'s above are replaced by the corresponding
values.
The handle C<err> value is set to $err if: $err is true; or handle
C<err> value is undef; or $err is defined and the length is greater
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Mon Feb 12 09:35:33 2007
@@ -513,12 +513,14 @@
if (SvTRUE(h_errstr)) {
/* append current err, if any, to errstr if it's going to change */
- if (SvTRUE(h_err) && SvTRUE(err))
+ if (SvTRUE(h_err) && SvTRUE(err) && strNE(SvPV_nolen(h_err),
SvPV_nolen(err)))
sv_catpvf(h_errstr, " [err was %s now %s]", SvPV_nolen(h_err),
SvPV_nolen(err));
- if (SvTRUE(h_state) && SvTRUE(state))
+ if (SvTRUE(h_state) && SvTRUE(state) && strNE(SvPV_nolen(h_state),
SvPV_nolen(state)))
sv_catpvf(h_errstr, " [state was %s now %s]", SvPV_nolen(h_state),
SvPV_nolen(state));
- sv_catpvn(h_errstr, "\n", 1);
- sv_catsv(h_errstr, errstr);
+ if (strNE(SvPV_nolen(h_errstr), SvPV_nolen(errstr))) {
+ sv_catpvn(h_errstr, "\n", 1);
+ sv_catsv(h_errstr, errstr);
+ }
}
else
sv_setsv(h_errstr, errstr);
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Mon Feb 12 09:35:33 2007
@@ -135,7 +135,7 @@
# Return a list of all subdirectories
my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym;
my $haveFileSpec = eval { require File::Spec };
- my $dir = $haveFileSpec ? File::Spec->curdir() : ".";
+ my $dir = $catalog || ($haveFileSpec ? File::Spec->curdir() : ".");
my @list;
if ($types{VIEW}) { # for use by test harness
push @list, [ undef, "schema", "table", 'VIEW', undef ];
@@ -147,13 +147,13 @@
if ($types{TABLE}) {
no strict 'refs';
opendir($dh, $dir)
- or return $dbh->set_err(int($!),
- "Failed to open directory $dir: $!");
- while (defined(my $file = readdir($dh))) {
+ or return $dbh->set_err(int($!), "Failed to open directory
$dir: $!");
+ while (defined(my $item = readdir($dh))) {
+ my $file = ($haveFileSpec) ? File::Spec->catdir($dir,$item) :
$item;
next unless -d $file;
my($dev, $ino, $mode, $nlink, $uid) = lstat($file);
my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid;
- push @list, [ $dir, $pwnam, $file, 'TABLE', undef ];
+ push @list, [ $dir, $pwnam, $item, 'TABLE', undef ];
}
close($dh);
}
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Mon Feb 12 09:35:33 2007
@@ -134,14 +134,18 @@
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 };
+ # XXX user/pass of fwd server vs db server ? also impact of
autoproxy
+ if ($user) {
+ $go_attr->{Username} = $user;
+ $go_attr->{Password} = $auth;
+ }
+ # delete any attributes we can't serialize (or don't want to)
delete @{$go_attr}{qw(Profile HandleError HandleSetErr Callbacks)};
$request_class->new({
- connect_args => [ $remote_dsn, $user, $auth, $go_attr ]
+ connect_args => [ $remote_dsn, $go_attr ]
})
} or return $drh->set_err(1, "Error instanciating $request_class $@");
@@ -200,6 +204,8 @@
my $transport = $dbh->{go_trans}
or return $dbh->set_err(1, "Not connected (no transport)");
+ my $TraceLevel = $dbh->FETCH('TraceLevel');
+ $transport->trace( $TraceLevel - 4 ) if $TraceLevel > 4;
eval { $transport->transmit_request($request) }
or return $dbh->set_err(1, "transmit_request failed: $@");
@@ -369,8 +375,11 @@
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;
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};
Modified: dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm Mon Feb 12 09:35:33 2007
@@ -38,7 +38,7 @@
my ($wfh, $rfh, $efh) = (gensym, gensym, gensym);
my $pid = open3($wfh, $rfh, $efh, @$cmd)
or die "error starting $cmd: $!\n";
- warn "Started pid $pid: $cmd\n" if $self->trace;
+ $self->trace_msg("Started pid $pid: $cmd\n") if $self->trace;
return {
cmd=>$cmd,
Modified: dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/stream.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/stream.pm Mon Feb 12 09:35:33 2007
@@ -56,7 +56,7 @@
# send frozen request
print $wfh $frozen_request # autoflush enabled
or die "Error sending request: $!";
- warn "Request: $frozen_request" if $self->trace >= 3;
+ $self->trace_msg("Request: $frozen_request\n") if $self->trace >= 3;
};
if ($@) {
my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
@@ -101,7 +101,8 @@
return DBI::Gofer::Response->new({ err => 1, errstr => $msg });
}
#warn DBI::neat($frozen_response);
- warn "Gofer stream stderr message: $stderr_msg\n" if $stderr_msg &&
$self->trace;
+ $self->trace_msg("Gofer stream stderr message: $stderr_msg\n")
+ if $stderr_msg && $self->trace;
# XXX need to be able to detect and deal with corruption
$response = $self->thaw_data(pack("H*",$frozen_response));
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 09:35:33 2007
@@ -19,16 +19,23 @@
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\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
+ check_connect
+ default_connect_dsn
+ forced_connect_dsn
+ default_connect_attributes
+ forced_connect_attributes
+ requests_served_count
));
+sub new {
+ my ($self, $args) = @_;
+ $args->{default_connect_attributes} ||= {};
+ $args->{forced_connect_attributes} ||= {};
+ return $self->SUPER::new($args);
+}
+
+
my @sth_std_attr = qw(
NUM_OF_PARAMS
NUM_OF_FIELDS
@@ -84,20 +91,58 @@
sub _connect {
my ($self, $request) = @_;
- local $ENV{DBI_AUTOPROXY}; # limit the insanity
+ # just a quick hack for now
+ if (++$self->{request_count} % 100 == 0) { # XXX config
+ # discard CachedKids from time to time
+ my %drivers = DBI->installed_drivers();
+ while ( my ($driver, $drh) = each %drivers ) {
+ next if $driver eq 'Gofer'; # ie transport=null when testing
+ next unless my $CK = $drh->{CachedKids};
+ # XXX currently we discard all regardless
+ # because that avoids the need to also handle
+ # limiting the prepared statement cache
+ my $cached_dbh_count = keys %$CK;
+ #next unless $cached_dbh_count > 20; # XXX config
+
+ DBI->trace_msg("Clearing $cached_dbh_count cached dbh from
$driver");
+ $_->{Active} && $_->disconnect for values %$CK;
+ %$CK = ();
+ }
+ }
- my ($dsn, $u, $p, $attr) = @{ $request->connect_args };
+ my ($dsn, $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)};
+ # (Could just do this on client-side and trust the client. DoS?)
+ delete @{$attr}{qw(Profile InactiveDestroy HandleError HandleSetErr
TraceLevel Taint TaintIn TaintOut)};
my $connect_method = 'connect_cached';
- # XXX need way to limit/purge connect cache over time
- my $dbh = DBI->$connect_method($dsn, $u, $p, {
+ my $check_connect = $self->check_connect;
+ $check_connect->($dsn, $attr, $connect_method, $request) if $check_connect;
+
+ $dsn = $self->forced_connect_dsn || $dsn || $self->default_connect_dsn
+ or die "No forced_connect_dsn, requested dsn, or default_connect_dsn
for request";
+
+ local $ENV{DBI_AUTOPROXY}; # limit the insanity
+
+ # XXX implement our own private connect_cached method?
+ my $dbh = DBI->$connect_method($dsn, undef, undef, {
+
+ # the configured default attributes, if any
+ %{ $self->default_connect_attributes },
+
+ # the requested attributes
%$attr,
- # force some attributes the way we want them
+
+ # force some attributes the way we'd like them
PrintWarn => 0,
PrintError => 0,
+
+ # the configured default attributes, if any
+ %{ $self->forced_connect_attributes },
+
+ # RaiseError must be enabled
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 => __PACKAGE__,
@@ -145,12 +190,16 @@
my @warnings;
local $SIG{__WARN__} = sub { push @warnings, @_ };
DBI->trace_msg("-----> execute_request\n");
+
my $response = eval {
+
($request->is_sth_request)
? $self->execute_sth_request($request)
: $self->execute_dbh_request($request);
};
- $response = $self->new_response_with_err(undef, $@) if $@;
+ $response = $self->new_response_with_err(undef, $@)
+ if $@;
+
$response->warnings([EMAIL PROTECTED]) if @warnings;
DBI->trace_msg("<----- execute_request\n");
return $response;
@@ -267,4 +316,5 @@
return \%meta;
}
+
1;
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 Mon Feb 12 09:35:33 2007
@@ -65,8 +65,23 @@
sub _dump {
my ($self, $label, $data) = @_;
require Data::Dumper;
- # XXX config dumper format
- warn "$label=".Data::Dumper::Dumper($data);
+ local $Data::Dumper::Indent = 1;
+ local $Data::Dumper::Terse = 1;
+ local $Data::Dumper::Useqq = 1;
+ local $Data::Dumper::Sortkeys = 1;
+ local $Data::Dumper::Quotekeys = 0;
+ local $Data::Dumper::Deparse = 0;
+ local $Data::Dumper::Purity = 0;
+ $self->trace_msg("$label=".Data::Dumper::Dumper($data));
+}
+
+
+sub trace_msg {
+ my ($self, $msg, $min_level) = @_;
+ $min_level = 1 unless defined $min_level;
+ # modeled on DBI's trace_msg method
+ return 0 if $self->trace < $min_level;
+ return DBI->trace_msg($msg, 1); # XXX two min_levels at play here
}
1;
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 09:35:33 2007
@@ -13,7 +13,7 @@
my $transport = __PACKAGE__->new();
-my %executor_configs;
+my %executor_configs = ( default => { } );
my %executor_cache;
@@ -35,6 +35,14 @@
}
+my $proto_config = { # defines valid keys and types for exector config
+ default_connect_dsn => 1,
+ forced_connect_dsn => 1,
+ default_connect_attributes => {},
+ forced_connect_attributes => {},
+};
+
+
sub executor_for_uri {
my ($self, $r) = @_;
my $uri = $r->uri;
@@ -50,17 +58,23 @@
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');
+ die "$uri: GoferConfig '$config_name' not defined";
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;
+ while ( my ($item_name, $proto_type) = each %$proto_config ) {
+ next if not exists $config->{$item_name};
+ my $item_value = $config->{$item_name};
+ if (ref $proto_type) {
+ my $merged = $merged_config{$item_name} ||= {};
+ warn "$uri: GoferConfig $config_name $item_name (@{[
%$item_value ]})\n"
+ if keys %$item_value;
+ $merged->{$_} = $item_value->{$_} for keys %$item_value;
+ }
+ else {
+ warn "$uri: GoferConfig $config_name $item_name:
'$item_value'\n"
+ if defined $item_value;
+ $merged_config{$item_name} = $item_value;
+ }
}
}
my $executor = DBI::Gofer::Execute->new(\%merged_config);
@@ -70,6 +84,11 @@
sub configuration { # one-time setup from httpd.conf
my ($self, $configs) = @_;
+ while ( my ($config_name, $config) = each %$configs ) {
+ my @bad = grep { not exists $proto_config->{$_} } keys %$config;
+ warn "Unknown keys in $self configuration '$config_name': @bad\n"
+ if @bad;
+ }
%executor_configs = %$configs;
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Mon Feb 12 09:35:33 2007
@@ -768,10 +768,10 @@
if ($h->{errstr}) {
$h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum
- if $h->{err} && $errnum;
+ if $h->{err} && $errnum && $h->{err} ne $errnum;
$h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state
- if $h->{state} and $h->{state} ne "S1000" && $state;
- $h->{errstr} .= "\n$msg";
+ if $h->{state} and $h->{state} ne "S1000" && $state &&
$h->{state} ne $state;
+ $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg;
$DBI::errstr = $h->{errstr};
}
else {
Modified: dbi/trunk/lib/DBI/Util/_accessor.pm
==============================================================================
--- dbi/trunk/lib/DBI/Util/_accessor.pm (original)
+++ dbi/trunk/lib/DBI/Util/_accessor.pm Mon Feb 12 09:35:33 2007
@@ -1,5 +1,6 @@
package DBI::Util::_accessor;
use strict;
+use Carp;
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/);
# heavily cut-down (but compatible) version of Class::Accessor::Fast to avoid
the dependency
@@ -7,8 +8,12 @@
sub new {
my($proto, $fields) = @_;
my($class) = ref $proto || $proto;
- $fields = {} unless defined $fields;
- # make a copy of $fields.
+ $fields ||= {};
+
+ my @dubious = grep { !m/^_/ && !$proto->can($_) } keys %$fields;
+ carp "$class doesn't have accessors for fields: @dubious" if @dubious;
+
+ # make a (shallow) copy of $fields.
bless {%$fields}, $class;
}
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Mon Feb 12 09:35:33 2007
@@ -492,22 +492,24 @@
print "table_info\n";
# First generate a list of all subdirectories
-$dir = $haveFileSpec ? File::Spec->curdir() : ".";
+$dir = getcwd();
ok(opendir(DIR, $dir));
my(%dirs, %unexpected, %missing);
while (defined(my $file = readdir(DIR))) {
$dirs{$file} = 1 if -d $file;
}
+print "Local $dir subdirs: @{[ keys %dirs ]}\n";
closedir(DIR);
-my $sth = $dbh->table_info(undef, undef, "%", "TABLE");
+#$dbh->trace(9);
+my $sth = $dbh->table_info($dir, undef, "%", "TABLE");
ok($sth);
%unexpected = %dirs;
%missing = ();
while (my $ref = $sth->fetchrow_hashref()) {
if (exists($unexpected{$ref->{'TABLE_NAME'}})) {
- delete $unexpected{$ref->{'TABLE_NAME'}};
+ delete $unexpected{$ref->{'TABLE_NAME'}};
} else {
- $missing{$ref->{'TABLE_NAME'}} = 1;
+ $missing{$ref->{'TABLE_NAME'}} = 1;
}
}
ok(keys %unexpected == 0)
@@ -515,6 +517,7 @@
ok(keys %missing == 0)
or print "Missing directories: ", join(",", keys %missing), "\n";
+#$dbh->trace(0); die 1;
print "tables\n";
my @tables_expected = (
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Mon Feb 12 09:35:33 2007
@@ -4,6 +4,7 @@
use strict;
use File::Path;
use Test::More;
+use Cwd;
use Config qw(%Config);
my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||'') =~ /^dbi:Gofer.*transport=/i;
@@ -56,7 +57,7 @@
}
}
-my $dir = './test_output';
+my $dir = getcwd().'/test_output';
rmtree $dir;
mkpath $dir;
