Author: timbo
Date: Tue Feb 20 15:41:12 2007
New Revision: 9145
Modified:
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/Transport/Base.pm
dbi/trunk/t/85gofer.t
Log:
Fix trace_msg calls so DBD_GOFER_TRACE works independently of DBI_TRACE
Removed SAMEPERL mechanism.
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Tue Feb 20 15:41:12 2007
@@ -219,8 +219,6 @@
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: $@");
@@ -414,8 +412,6 @@
my $transport = $sth->{go_trans}
or return $sth->set_err(1, "Not connected (no transport)");
- my $TraceLevel = $sth->FETCH('TraceLevel');
- $transport->trace( (($TraceLevel-4) > 0) ? $TraceLevel-4 : 0 );
eval { $transport->transmit_request($request) }
or return $sth->set_err(1, "transmit_request failed: $@");
@@ -882,4 +878,6 @@
so that web caches (squid etc) could be used to implement the caching.
(May require the use of GET rather than POST requests.)
+Neat way for $h->trace to enable transport tracing.
+
=cut
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 15:41:12 2007
@@ -12,7 +12,6 @@
use IPC::Open3 qw(open3);
use Symbol qw(gensym);
-use Config;
use base qw(DBD::Gofer::Transport::Base);
@@ -25,14 +24,10 @@
));
-my $this_perl = $^X;
-$this_perl .= $Config{_exe}
- if $^O ne 'VMS' && $this_perl !~ m/$Config{_exe}$/i;
-
-
sub new {
my ($self, $args) = @_;
- if ($args->{go_perl} and not ref $args->{go_perl}) {
+ $args->{go_perl} ||= [ $^X ];
+ if (not ref $args->{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,
@@ -48,15 +43,6 @@
my ($self, $cmd) = @_;
$cmd = [ $cmd ] unless ref $cmd eq 'ARRAY';
- # translate any SAMEPERL in cmd to $this_perl
- my $perl = $self->go_perl || [ $this_perl ];
- for (my $i=0; $i < @$cmd; $i++) {
- next unless $cmd->[$i] eq 'SAMEPERL';
- splice @$cmd, $i, 1, @$perl;
- $i += @$perl - 1;
- }
- $_ eq 'SAMEPERL' and $_ = $this_perl for @$cmd;
-
# if it's important that the subprocess uses the same
# (versions of) modules as us then the caller should
# set PERL5LIB itself.
@@ -69,7 +55,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") if $self->trace;
+ $self->trace_msg("Started pid $pid: $cmd\n",0) if $self->trace;
return {
cmd=>$cmd,
@@ -94,7 +80,7 @@
my $info = eval {
my $frozen_request = $self->freeze_data($request);
- my $cmd = [ qw(SAMEPERL -MDBI::Gofer::Transport::pipeone -e
run_one_stdio)];
+ 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};
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 15:41:12 2007
@@ -41,7 +41,7 @@
$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");
+ DBI->trace_msg("reusing persistent connection $key\n",0) if
$self->trace >= 1;
return $persist{$key};
}
@@ -83,25 +83,23 @@
sub _make_connection {
my ($self) = @_;
- my $cmd = [qw(SAMEPERL -MDBI::Gofer::Transport::stream -e run_stdio_hex)];
- if (0 and my $perl = $self->go_perl) {
- splice @$cmd, 0, 1, @$perl;
- }
+ my $go_perl = $self->go_perl;
+ my $cmd = [ @$go_perl, qw(-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://;
- $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 "$@"};
+ # don't use $^X on remote system by default as it's possibly wrong
+ $cmd->[0] = 'perl' if "@$go_perl" eq $^X;
# -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");
+ DBI->trace_msg("new connection: @$cmd\n",0) if $self->trace;
# 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
@@ -134,7 +132,7 @@
$self->_connection_kill;
die "Error sending request: $!";
};
- $self->trace_msg("Request: $frozen_request\n") if $self->trace >= 3;
+ $self->trace_msg("Request: $frozen_request\n",0) if $self->trace >= 4;
};
if ($@) {
my $response = DBI::Gofer::Response->new({ err => 1, errstr => $@ });
@@ -178,8 +176,11 @@
$msg .= $stderr_msg || $frozen_response_errno;
return DBI::Gofer::Response->new({ err => 1, errstr => $msg });
}
+
+ $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")
+ $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
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 Tue Feb 20 15:41:12 2007
@@ -82,7 +82,7 @@
$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
+ return DBI->trace_msg($msg, 0); # 0 to force logging even if DBI trace not
enabled
}
1;
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Tue Feb 20 15:41:12 2007
@@ -47,7 +47,7 @@
my $getcwd = getcwd();
my $username = eval { getpwuid($>) } || ''; # fails on windows
my $can_ssh = ($username && $username eq 'timbo' && -d '.svn');
-my $perl = "SAMEPERL -Mblib=$getcwd/blib"; # ensure sameperl and our blib
(note two spaces)
+my $perl = "$^X -Mblib=$getcwd/blib"; # ensure sameperl and our blib (note
two spaces)
my %trials = (
null => {},
@@ -56,7 +56,7 @@
stream_ssh => ($can_ssh)
? { perl=>$perl, url => "ssh:[EMAIL PROTECTED]" }
: undef,
- http => { url => "http://localhost:8001/gofer"; },
+ #http => { url => "http://localhost:8001/gofer"; },
);
# too dependant on local config to make a standard test
