Author: timbo
Date: Wed Mar 28 05:48:35 2007
New Revision: 9354
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Policy/rush.pm
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/13taint.t
dbi/trunk/t/43prof_env.t
dbi/trunk/t/85gofer.t
Log:
Make gofer timeout handling more useful and thorough (kill subprocess for
stream)
Make PurePerl easier to debug.
Make PurePerl faster by avoiding calls to FETCH('err') for many dispatches.
Gofer dbh_attribute_update policy now only affects if it's every req or only
the first
(this is to make skip_default_methods policy work better - which is more
valuable)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Wed Mar 28 05:48:35 2007
@@ -8,10 +8,9 @@
http://buildd.debian.org/fetch.cgi?&pkg=libdbi-perl&ver=1.54-1&arch=m68k&stamp=1174636818&file=log
-Implement quote() in C fallback to perl _quote() if $datatype true (and not
var/char?)
-Implement tie in C.
-
-Add attr-passthru to prepare()?
+Allow connect via subclass to support DBIx::HA
+prepare(...,{ Err=>\my $isolated_err, ...})
+Add attr-passthru to prepare()? ie for gofer cache control
Terminology for client and server ends
Document user/passwd issues at the various levels of the stack
Policy's from pod
@@ -22,9 +21,7 @@
Refactor http transport like the others re timeout
Call method on transport timeout so transport can cleanup/reset it it wants
-Profile: autoderef Path elements that are refs (ref to scalar & ref to array)
- to make it cheap to gather path 'dynamically' from existing dynamic values
-prepare(...,{ Err=>\my $isolated_err, ...})
+Implement tie in C.
Add trace modules that just records the last N trace messages into an array
and prepends them to any error message.
@@ -38,6 +35,7 @@
Changed _set_fbav to not croak when given a wrongly sized array,
it now warns and adjusts the row buffer to match.
Changed DBD::NullP to be vaguely useful for testing.
+ Changed File::Spec prerequisite to not require a minimum version.
Assorted Gofer bug fixes, enhancements and docs.
Added support for install_methods to DBD::Gofer.
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Wed Mar 28 05:48:35 2007
@@ -243,7 +243,7 @@
my $dbh_attribute_update = $go_policy->dbh_attribute_update();
$request->dbh_attributes( $go_policy->dbh_attribute_list() )
if $dbh_attribute_update eq 'every'
- or $dbh_attribute_update eq 'first' && $dbh->{go_request_count}==1;
+ or $dbh->{go_request_count}==1;
$request->dbh_last_insert_id_args($meta->{go_last_insert_id_args})
if $meta->{go_last_insert_id_args};
@@ -551,7 +551,7 @@
my $dbh_attribute_update = $go_policy->dbh_attribute_update();
$request->dbh_attributes( $go_policy->dbh_attribute_list() )
if $dbh_attribute_update eq 'every'
- or $dbh_attribute_update eq 'first' && $dbh->{go_request_count}==1;
+ or $dbh->{go_request_count}==1;
my $transport = $sth->{go_transport}
or return $sth->set_err(1, "Not connected (no transport)");
Modified: dbi/trunk/lib/DBD/Gofer/Policy/rush.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Policy/rush.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Policy/rush.pm Wed Mar 28 05:48:35 2007
@@ -31,8 +31,10 @@
skip_ping => 1,
# don't update dbh attributes at all
- dbh_attribute_update => 'none',
- dbh_attribute_list => undef,
+ # XXX actually we currently need dbh_attribute_update for
skip_default_methods to work
+ # and skip_default_methods is more valuable to us than the cost of
dbh_attribute_update
+ dbh_attribute_update => 'none', # actually means 'first' currently
+ #dbh_attribute_list => undef,
# we'd like to set locally_* but can't because drivers differ
Modified: dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/Base.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/Base.pm Wed Mar 28 05:48:35 2007
@@ -28,15 +28,20 @@
my ($self, $request) = @_;
my $to = $self->go_timeout;
- local $SIG{ALRM} = sub { die "transmit_request timed-out after $to
seconds" }
- if $to;
+ local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
my $info = eval {
alarm($to) if $to;
$self->transmit_request_by_transport($request);
};
alarm(0) if $to;
- return DBI::Gofer::Response->new({ err => 1, errstr => $@ }) if $@;
+
+ if ($@) {
+ return $self->transport_timedout("transmit_request", $to)
+ if $@ eq "TIMEOUT\n";
+ return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ }
+
return undef;
}
@@ -45,8 +50,7 @@
my $self = shift;
my $to = $self->go_timeout;
- local $SIG{ALRM} = sub { die "receive_response timed-out after $to
seconds" }
- if $to;
+ local $SIG{ALRM} = sub { die "TIMEOUT\n" } if $to;
my $response = eval {
alarm($to) if $to;
@@ -54,13 +58,22 @@
};
alarm(0) if $to;
- return DBI::Gofer::Response->new({ err => 1, errstr => $@ })
- if $@;
+ if ($@) {
+ return $self->transport_timedout("receive_response", $to)
+ if $@ eq "TIMEOUT\n";
+ return DBI::Gofer::Response->new({ err => 1, errstr => $@ });
+ }
return $response;
}
+sub transport_timedout {
+ my ($self, $method, $timeout) = @_;
+ $timeout ||= $self->go_timeout;
+ return DBI::Gofer::Response->new({ err => 1, errstr => "DBD::Gofer $method
timed-out after $timeout seconds" });
+}
+
1;
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 Wed Mar 28 05:48:35 2007
@@ -54,7 +54,7 @@
my ($wfh, $rfh, $efh) = (gensym, gensym, gensym);
my $pid = open3($wfh, $rfh, $efh, @$cmd)
or die "error starting @$cmd: $!\n";
- $self->trace_msg("Started pid $pid: $cmd\n",0) if $self->trace;
+ $self->trace_msg("Started pid $pid: @$cmd\n",0) 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 Wed Mar 28 05:48:35 2007
@@ -182,6 +182,11 @@
return $response;
}
+sub transport_timedout {
+ my $self = shift;
+ $self->_connection_kill;
+ return $self->SUPER::transport_timedout(@_);
+}
# nonblock($fh) puts filehandle into nonblocking mode
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 Wed Mar 28 05:48:35 2007
@@ -79,6 +79,7 @@
return;
}
else {
+ Carp::cluck("$label from");
my $summary = eval { $data->summary_as_text } || $@ || "no summary
available\n";
$self->trace_msg("$label: $summary");
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Wed Mar 28 05:48:35 2007
@@ -321,7 +321,10 @@
} if IMA_END_WORK & $bitmask;
push @post_call_frag, q{
- if ( ref $ret[0] and defined( (my $h_new = $ret[0])->{err} ) ) {
+ if ( ref $ret[0] and
+ UNIVERSAL::isa($ret[0], 'DBI::_::common') and
+ defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} )
+ ) {
# copy up info/warn to drh so PrintWarn on connect is triggered
$h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state})
}
@@ -389,7 +392,7 @@
$h = $h_inner if $h_inner;
my $imp;
- if ($method_name eq 'DESTROY') {
+ if ($method_name eq 'DESTROY') { # XXX move this into pre_call_frag
# during global destruction, $h->{...} can trigger "Can't call
FETCH on an undef value"
# implying that tied() above lied to us, so we need to use eval
local $@; # protect $@
@@ -426,13 +429,13 @@
}
];
no strict qw(refs);
- my $code_ref = eval qq{#line 1 "$method"\n$method_code};
+ my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code};
warn "[EMAIL PROTECTED]" if $@;
die "[EMAIL PROTECTED]" if $@;
*$method = $code_ref;
- if (0 && $method =~ /do/) { # debuging tool
+ if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool
my $l=0; # show line-numbered code for method
- warn "*$method = ".join("\n", map { ++$l.": $_" }
split/\n/,$method_code);
+ warn "*$method code:\n".join("\n", map { ++$l.": $_" }
split/\n/,$method_code);
}
}
@@ -794,7 +797,7 @@
}
sub trace_msg {
my ($h, $msg, $minlevel)[EMAIL PROTECTED];
- $minlevel = 1 unless $minlevel;
+ $minlevel = 1 unless defined $minlevel;
return unless $minlevel <= ($DBI::dbi_debug & 0xF);
print $DBI::tfh $msg;
return 1;
Modified: dbi/trunk/t/13taint.t
==============================================================================
--- dbi/trunk/t/13taint.t (original)
+++ dbi/trunk/t/13taint.t Wed Mar 28 05:48:35 2007
@@ -10,7 +10,6 @@
$^W = 1;
$| = 1;
-my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';
use Test::More;
Modified: dbi/trunk/t/43prof_env.t
==============================================================================
--- dbi/trunk/t/43prof_env.t (original)
+++ dbi/trunk/t/43prof_env.t Wed Mar 28 05:48:35 2007
@@ -12,7 +12,6 @@
use DBI;
use DBI::Profile;
-use File::Spec;
use Config;
use Data::Dumper;
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Wed Mar 28 05:48:35 2007
@@ -117,10 +117,10 @@
print " $dsn\n";
my $dbh = DBI->connect($dsn, undef, undef, { RaiseError => 1, PrintError
=> 0 } );
- ok $dbh, sprintf "should connect to %s (%s)", $dsn, $DBI::errstr||'';
- die "$test_run_tag aborted\n" unless $dbh;
+ die "$test_run_tag aborted: $DBI::errstr\n" unless $dbh; # no point
continuing
+ ok $dbh, sprintf "should connect to %s", $dsn;
- is $dbh->{Name}, ($policy->skip_connect_check or
$policy->dbh_attribute_update eq 'none')
+ is $dbh->{Name}, ($policy->skip_connect_check)
? $driver_dsn
: $remote_driver_dsn;
@@ -171,14 +171,20 @@
ok $dbh->do("DROP TABLE fruit");
is ++$go_request_count, $dbh->{go_request_count};
+ # actuall tests go_request_count, caching, and skip_default_methods policy
my $use_remote = ($policy->skip_default_methods) ? 0 : 1;
- warn "use_remote=$use_remote (policy=$policy_name, transport=$transport)
$dbh->{dbi_default_methods}\n";
+ print "use_remote=$use_remote (policy=$policy_name, transport=$transport)
$dbh->{dbi_default_methods}\n";
+
+SKIP: {
+ skip "skip_default_methods checking doesn't work with Gofer over Gofer", 3
+ if $ENV{DBI_AUTOPROXY};
$dbh->data_sources({ foo_bar => $go_request_count });
is $dbh->{go_request_count}, $go_request_count + 1*$use_remote;
$dbh->data_sources({ foo_bar => $go_request_count }); # should use cache
is $dbh->{go_request_count}, $go_request_count + 1*$use_remote;
@_=$dbh->data_sources({ foo_bar => $go_request_count }); # no cached yet
due to wantarray
is $dbh->{go_request_count}, $go_request_count + 2*$use_remote;
+}
SKIP: {
skip "caching of metadata methods returning sth not yet implemented", 2;
