Author: timbo
Date: Tue Feb 20 16:54:06 2007
New Revision: 9147
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/Base.pm
dbi/trunk/lib/DBD/Gofer/Transport/http.pm
dbi/trunk/lib/DBD/Gofer/Transport/null.pm
dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
dbi/trunk/t/85gofer.t
Log:
Refactor transmit_request and receive_response into Base
and add timeout functionality.
Use refactoring to simplify other transports (except http thus far).
Drop pending_response concept (except in null), implement in DBD::Gofer
directly.
Enable timeout in t.85gofer.t
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Tue Feb 20 16:54:06 2007
@@ -15,7 +15,8 @@
or piggyback on skip_connect_check
could also remember which attr have been returned to us
so not bother FETCHing them (unless pedantic)
-
+Refactor http transport like the others re timeout
+Call method on transport timeout so transport can cleanup/reset it it wants
=head2 Changes in DBI 1.54 (svn rev 9140), 19th February 2007
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Tue Feb 20 16:54:06 2007
@@ -220,10 +220,8 @@
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 $response = $transport->transmit_request($request);
+ $response ||= $transport->receive_response;
$dbh->{go_response} = $response;
if (my $dbh_attributes = $response->dbh_attributes) {
@@ -412,14 +410,13 @@
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: $@");
-
- delete $sth->{go_method_calls};
- my $response = $transport->receive_response;
+ my $response = $transport->transmit_request($request);
+ $response ||= $transport->receive_response;
$sth->{go_response} = $response;
+ delete $sth->{go_method_calls};
+
if (my $dbh_attributes = $response->dbh_attributes) {
# XXX we don't STORE here, we just stuff the value into the
attribute cache
$dbh->{$_} = $dbh_attributes->{$_}
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 Tue Feb 20 16:54:06 2007
@@ -18,11 +18,50 @@
trace
go_dsn
go_url
+ go_timeout
));
sub _init_trace { $ENV{DBD_GOFER_TRACE} || 0 }
+sub transmit_request {
+ my ($self, $request) = @_;
+
+ my $to = $self->go_timeout;
+ local $SIG{ALRM} = sub { die "transmit_request timed-out after $to
seconds" }
+ 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 $@;
+ return undef;
+}
+
+
+sub receive_response {
+ my $self = shift;
+
+ my $to = $self->go_timeout;
+ local $SIG{ALRM} = sub { die "receive_response timed-out after $to
seconds" }
+ if $to;
+
+ my $response = eval {
+ alarm($to) if $to;
+ $self->receive_response_by_transport();
+ };
+ alarm(0) if $to;
+
+ return DBI::Gofer::Response->new({ err => 1, errstr => $@ })
+ if $@;
+
+ return $response;
+}
+
+
+
1;
=head1 NAME
Modified: dbi/trunk/lib/DBD/Gofer/Transport/http.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/http.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/http.pm Tue Feb 20 16:54:06 2007
@@ -21,7 +21,6 @@
__PACKAGE__->mk_accessors(qw(
connection_info
- response_info
));
my $encoding = "binary";
@@ -58,14 +57,7 @@
my $res = $ua->request($req);
$self->connection_info( $res );
};
- if ($@) {
- my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
- $self->response_info($response);
- }
- else {
- $self->response_info(undef);
- }
-
+ return DBI::Gofer::Response->new({ err => 1, errstr => $@ }) if $@;
return 1;
}
@@ -73,9 +65,6 @@
sub receive_response {
my $self = shift;
- my $response = $self->response_info;
- return $response if $response; # failed while starting
-
my $res = $self->connection_info || die;
if (not $res->is_success) {
Modified: dbi/trunk/lib/DBD/Gofer/Transport/null.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/null.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/null.pm Tue Feb 20 16:54:06 2007
@@ -45,7 +45,7 @@
# put response 'on the shelf' ready for receive_response()
$self->pending_response( $response );
- return 1;
+ return undef;
}
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 Tue Feb 20 16:54:06 2007
@@ -19,7 +19,6 @@
__PACKAGE__->mk_accessors(qw(
connection_info
- response_info
go_perl
));
@@ -74,63 +73,43 @@
}
-sub transmit_request {
+sub transmit_request_by_transport {
my ($self, $request) = @_;
- my $info = eval {
- my $frozen_request = $self->freeze_data($request);
+ my $frozen_request = $self->freeze_data($request);
- my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e
run_one_stdio)];
- my $info = $self->start_pipe_command($cmd);
+ my $cmd = [ @{$self->go_perl}, qw(-MDBI::Gofer::Transport::pipeone -e
run_one_stdio)];
+ my $info = $self->start_pipe_command($cmd);
- my $wfh = delete $info->{wfh};
- # send frozen request
- print $wfh $frozen_request;
- # indicate that there's no more
- close $wfh
- or die "error writing to @$cmd: $!\n";
+ my $wfh = delete $info->{wfh};
+ # send frozen request
+ print $wfh $frozen_request;
+ # indicate that there's no more
+ close $wfh
+ or die "error writing to @$cmd: $!\n";
- $info; # so far so good. return the state info
- };
- if ($@) {
- my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
- $self->response_info($response);
- }
- else {
- $self->response_info(undef);
- }
-
- # record what we need to get a response, ready for receive_response()
$self->connection_info( $info );
-
- return 1;
+ return;
}
-sub receive_response {
+sub receive_response_by_transport {
my $self = shift;
- my $response = $self->response_info;
- return $response if $response; # failed while starting
-
my $info = $self->connection_info || die;
my ($pid, $rfh, $efh, $cmd) = @{$info}{qw(pid rfh efh cmd)};
- waitpid $info->{pid}, 0
- or warn "waitpid: $!"; # XXX do something more useful?
-
my $frozen_response = do { local $/; <$rfh> };
my $stderr_msg = do { local $/; <$efh> };
- if (not $frozen_response) { # no output on stdout at all
- return DBI::Gofer::Response->new({
- err => 1,
- errstr => ref($self)." command (@$cmd) failed: $stderr_msg",
- });
- }
+ waitpid $info->{pid}, 0
+ or warn "waitpid: $!"; # XXX do something more useful?
+
+ die ref($self)." command (@$cmd) failed: $stderr_msg"
+ if not $frozen_response; # no output on stdout at all
# XXX need to be able to detect and deal with corruption
- $response = $self->thaw_data($frozen_response);
+ my $response = $self->thaw_data($frozen_response);
if ($stderr_msg) {
warn "STDERR message from @$cmd: $stderr_msg"; # XXX remove later
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 Tue Feb 20 16:54:06 2007
@@ -110,49 +110,35 @@
}
-sub transmit_request {
+sub transmit_request_by_transport {
my ($self, $request) = @_;
- eval {
- my $connection = $self->connection_info || do {
- my $con = $self->_connection_get;
- $self->connection_info( $con );
- #warn ''.$self->cmd_as_string;
- $con;
- };
+ my $connection = $self->connection_info || do {
+ my $con = $self->_connection_get;
+ $self->connection_info( $con );
+ $con;
+ };
- my $frozen_request = unpack("H*", $self->freeze_data($request));
- $frozen_request .= "\n";
+ my $frozen_request = unpack("H*", $self->freeze_data($request));
+ $frozen_request .= "\n";
- my $wfh = $connection->{wfh};
- # send frozen request
- print $wfh $frozen_request # autoflush enabled
- or do {
- # XXX should make new connection and retry
- $self->_connection_kill;
- die "Error sending request: $!";
- };
- $self->trace_msg("Request: $frozen_request\n",0) if $self->trace >= 4;
- };
- if ($@) {
- my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
- $self->response_info($response);
- # return undef ?
- }
- else {
- $self->response_info(undef);
- }
+ my $wfh = $connection->{wfh};
+ # send frozen request
+ print $wfh $frozen_request # autoflush enabled
+ or do {
+ # XXX should make new connection and retry
+ $self->_connection_kill;
+ die "Error sending request: $!";
+ };
+ $self->trace_msg("Request: $frozen_request\n",0) if $self->trace >= 4;
- return 1;
+ return;
}
-sub receive_response {
+sub receive_response_by_transport {
my $self = shift;
- my $response = $self->response_info;
- return $response if $response; # failed while starting
-
my $connection = $self->connection_info || die;
my ($pid, $rfh, $efh) = @{$connection}{qw(pid rfh efh)};
@@ -167,24 +153,24 @@
my $stderr_msg = do { local $/; <$efh> }; # nonblocking
# if we got no output on stdout at all then the command has
- # proably exited, possibly with an error to stderr.
+ # probably exited, possibly with an error to stderr.
# Turn this situation into a reasonably useful DBI error.
if (not $frozen_response or !chomp $frozen_response) {
chomp $stderr_msg if $stderr_msg;
my $msg = sprintf("Error reading from %s (pid %d%s): ",
$self->cmd_as_string, $pid, (kill 0, $pid) ? "" : ", exited");
$msg .= $stderr_msg || $frozen_response_errno;
- return DBI::Gofer::Response->new({ err => 1, errstr => $msg });
+ die "$msg\n";
}
- $self->trace_msg("Response: $frozen_response\n",0) if $self->trace >= 4;
+ $self->trace_msg("Response: $frozen_response\n",0)
+ if $self->trace >= 4;
- #warn DBI::neat($frozen_response);
$self->trace_msg("Gofer stream stderr message: $stderr_msg\n",0)
if $stderr_msg && $self->trace;
# XXX need to be able to detect and deal with corruption
- $response = $self->thaw_data(pack("H*",$frozen_response));
+ my $response = $self->thaw_data(pack("H*",$frozen_response));
# add any stderr messages as a warning (ie PrintWarn)
$response->add_err(0, $stderr_msg, undef, $self->trace)
@@ -194,6 +180,7 @@
}
+
# nonblock($fh) puts filehandle into nonblocking mode
sub nonblock {
my $fh = shift;
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Tue Feb 20 16:54:06 2007
@@ -31,6 +31,7 @@
my $dbm = $ARGV[0] || "SDBM_File";
my $remote_driver_dsn = "dbm_type=$dbm;lockfile=0";
my $remote_dsn = "dbi:DBM:$remote_driver_dsn";
+my $timeout = 10;
if ($ENV{DBI_AUTOPROXY}) {
# this means we have DBD::Gofer => DBD::Gofer => DBD::DBM!
@@ -51,10 +52,10 @@
my %trials = (
null => {},
- pipeone => { perl=>$perl },
- stream => { perl=>$perl },
+ pipeone => { perl=>$perl, timeout=>$timeout },
+ stream => { perl=>$perl, timeout=>$timeout },
stream_ssh => ($can_ssh)
- ? { perl=>$perl, url => "ssh:[EMAIL PROTECTED]" }
+ ? { perl=>$perl, timeout=>$timeout, url => "ssh:[EMAIL
PROTECTED]" }
: undef,
#http => { url => "http://localhost:8001/gofer"; },
);
