Author: timbo
Date: Mon Feb 19 08:01:15 2007
New Revision: 9134
Modified:
dbi/trunk/lib/DBD/Gofer/Transport/stream.pm
Log:
Added connection persistence.
Added -x to ssh options (much faster connect)
Added ability to specify which perl (plus args) to use.
Added more docs
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 19 08:01:15 2007
@@ -18,37 +18,116 @@
our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);
__PACKAGE__->mk_accessors(qw(
+ go_perl
+ go_persist
));
+my $persist_all = 5;
+my %persist;
sub nonblock;
+
+sub _connection_key {
+ my ($self) = @_;
+ my $go_perl = $self->go_perl;
+ return join "~", $self->go_url, ref $go_perl ? @$go_perl : $go_perl||"";
+}
+
+
+sub _connection_get {
+ my ($self) = @_;
+
+ my $persist = $self->go_persist; # = 0 can force non-caching
+ $persist = $persist_all if not defined $persist;
+ my $key = ($persist) ? $self->_connection_key : '';
+ if ($persist{$key} && $self->_connection_check($persist{$key})) {
+ DBI->trace_msg("reusing persistent connection $key");
+ return $persist{$key};
+ }
+
+ my $connection = $self->_make_connection;
+
+ if ($key) {
+ %persist = () if keys %persist > $persist_all; # XXX quick hack to
limit subprocesses
+ $persist{$key} = $connection;
+ }
+
+ return $connection;
+}
+
+
+sub _connection_check {
+ my ($self, $connection) = @_;
+ $connection ||= $self->connection_info;
+ my $pid = $connection->{pid};
+ return (kill 0, $pid);
+}
+
+
+sub _connection_kill {
+ my ($self) = @_;
+ my $connection = $self->connection_info;
+ my ($pid, $wfh, $rfh, $efh) = @{$connection}{qw(pid wfh rfh efh)};
+ # closing the write file handle should be enough, generally
+ close $wfh;
+ # in code cases in future we may want to be more aggressive
+ #close $rfh; close $efh; kill 15, $pid
+ # but deleting from the persist cache...
+ delete $persist{ $self->_connection_key };
+ # ... and removing the connection_info should suffice
+ $self->connection_info( undef );
+ return;
+}
+
+
+sub _make_connection {
+ my ($self) = @_;
+
+ my $cmd = [qw(SAMEPERL -MDBI::Gofer::Transport::stream -e run_stdio_hex)];
+ if (my $perl = $self->go_perl) {
+ # user can override the perl to be used, either with an array ref
+ # containing the command name and args to use, or with a string
+ # (ie via the DSN) in which case, to enable args to be passed,
+ # we split on two or more consecutive spaces (otherwise the path
+ # to perl couldn't contain a space itself).
+ splice @$cmd, 0, 1, (ref $perl ? @$perl : split /\s{2,}/,$perl);
+ }
+
+ #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c";
+ if (my $url = $self->go_url) {
+ die "Only 'ssh:[EMAIL PROTECTED]' style url supported by this
transport"
+ unless $url =~ s/^ssh://;
+ $cmd->[0] = 'perl' unless $self->go_perl; # don't use SAMEPERL on
remote system
+ my $ssh = $url;
+ my $setup_env = join "||", map { "source $_ 2>/dev/null" }
qw(.bash_profile .bash_login .profile);
+ #my $setup_env = "{ . .bash_profile || . .bash_login || . .profile; }
2>/dev/null";
+ my $setup = $setup_env.q{; exec "$@"};
+ # -x not only 'Disables X11 forwarding' but also makes connections
*much* faster
+ unshift @$cmd, qw(ssh -xq), split(' ', $ssh), qw(bash -c), $setup;
+ }
+
+ DBI->trace_msg("new connection: @$cmd");
+
+ # XXX add a handshake - some message from DBI::Gofer::Transport::stream
that's
+ # sent as soon as it starts that we can wait for to report success - and
soak up
+ # and report useful warnings etc from ssh before we get it? Increases
latency though.
+ my $connection = $self->start_pipe_command($cmd);
+ nonblock($connection->{efh});
+ return $connection;
+}
+
+
sub transmit_request {
my ($self, $request) = @_;
eval {
-
- my $connection = $self->connection_info;
- if (not $connection || ($connection->{pid} && not kill 0,
$connection->{pid})) {
- my $cmd = [qw(SAMEPERL -MDBI::Gofer::Transport::stream -e
run_stdio_hex)];
- #push @$cmd, "DBI_TRACE=2=/tmp/goferstream.log", "sh", "-c";
- if (my $url = $self->go_url) {
- die "Only 'ssh:[EMAIL PROTECTED]' style url supported by this
transport"
- unless $url =~ s/^ssh://;
- my $ssh = $url;
- my $setup_env = join "||", map { "source $_ 2>/dev/null" }
- qw(.bash_profile .bash_login .profile);
- my $setup = $setup_env.q{; eval "$@"};
- $cmd->[0] = 'perl'; # don't use SAMEPERL on remote system
- unshift @$cmd, qw(ssh -q), split(' ', $ssh), qw(bash -c),
$setup;
- }
- # XXX add a handshake - some message from
DBI::Gofer::Transport::stream that's
- # sent as soon as it starts that we can wait for to report success
- and soak up
- # and useful warnings etc from shh before we get it.
- $connection = $self->start_pipe_command($cmd);
- nonblock($connection->{efh});
- $self->connection_info($connection);
- }
+ my $connection = $self->connection_info || do {
+ my $con = $self->_connection_get;
+ $self->connection_info( $con );
+ #warn ''.$self->cmd_as_string;
+ $con;
+ };
my $frozen_request = unpack("H*", $self->freeze_data($request));
$frozen_request .= "\n";
@@ -56,7 +135,11 @@
my $wfh = $connection->{wfh};
# send frozen request
print $wfh $frozen_request # autoflush enabled
- or die "Error sending request: $!";
+ or do {
+ # XXX should make new connection and retry
+ $self->_connection_kill;
+ die "Error sending request: $!";
+ };
$self->trace_msg("Request: $frozen_request\n") if $self->trace >= 3;
};
if ($@) {
@@ -149,21 +232,46 @@
and feeds requests into it and reads responses from it. But that's not very
useful.
-With a C<url=ssh:[EMAIL PROTECTED]> parameter it launches a subprocess as
-something like
+With a C<url=ssh:[EMAIL PROTECTED]> parameter it uses ssh to launch the
subprocess
+on a remote system. That's much more useful!
+
+It gives you secure remote access to DBI databases on any system you can login
to.
+Using ssh also gives you optional compression and many other features (see the
+ssh manual for how to configure that and many other options via ~/.ssh/config
file).
- ssh -q ssh:[EMAIL PROTECTED] bash -c $setup $run
+The actual command invoked is something like:
+
+ ssh -xq ssh:[EMAIL PROTECTED] bash -c $setup $run
where $run is the command shown above, and $command is
- source .bash_profile 2>/dev/null \
- || source .bash_login 2>/dev/null \
- || source .profile 2>/dev/null \
- ; eval "$@"
+ . .bash_profile 2>/dev/null || . .bash_login 2>/dev/null || . .profile
2>/dev/null; exec "$@"
-which is trying (in a limited an unportable way) to setup the environment
+which is trying (in a limited and fairly unportable way) to setup the
environment
(PATH, PERL5LIB etc) as it would be if you had logged in to that system.
+The "C<perl>" used in the command will default to the value of $^X when not
using ssh.
+On most systems that's the full path to the perl that's currently executing.
+
+
+=head1 PERSISTENCE
+
+Currently gofer stream connections persist (remain connected) after all
+database handles have been disconnected. This makes later connections in the
+same process very fast.
+
+Currently up to 5 different gofer stream connections (based on url) can
+persist. If more than 5 are in the cache when a new connection is made then
+the cache is cleared before adding the new connection. Simple but effective.
+
+=head1 TO DO
+
+Document go_perl attribute
+
+Automatically reconnect (within reason) if there's a transport error.
+
+Decide on default for persistent connection - on or off? limits? ttl?
+
=head1 SEE ALSO
L<DBD::Gofer>
