Author: timbo
Date: Sun Feb 18 08:35:38 2007
New Revision: 9125
Modified:
dbi/trunk/README
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/t/85gofer.t
Log:
Make pipeone and stream use $^X and not mess with PERL5LIB.
Add better diagnosits on failure.
Enable (local) stream testing in 85gofer.t
Fix 85gofer to report errors correctly.
Modified: dbi/trunk/README
==============================================================================
--- dbi/trunk/README (original)
+++ dbi/trunk/README Sun Feb 18 08:35:38 2007
@@ -69,6 +69,9 @@
make test TEST_VERBOSE=1 (if any of the t/* tests fail)
make install (if the tests look okay)
+The perl you use to execute Makefile.PL should be the first one in your PATH.
+If you want to use some installed perl then modify your PATH to match.
+
IF YOU HAVE PROBLEMS:
First, carefully read the notes at the bottom of this file.
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 Sun Feb 18 08:35:38 2007
@@ -42,8 +42,3 @@
L<DBI::Gofer::Transport::mod_perl>
=cut
-
-
-=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 Sun Feb 18 08:35:38 2007
@@ -12,6 +12,7 @@
use IPC::Open3 qw(open3);
use Symbol qw(gensym);
+use Config;
use base qw(DBD::Gofer::Transport::Base);
@@ -23,12 +24,22 @@
));
+my $this_perl = $^X;
+$this_perl .= $Config{_exe}
+ if $^O ne 'VMS' && $this_perl !~ m/$Config{_exe}$/i;
+
+
sub start_pipe_command {
my ($self, $cmd) = @_;
$cmd = [ $cmd ] unless ref $cmd eq 'ARRAY';
- # ensure subprocess will use the same modules as us
- local $ENV{PERL5LIB} = join ":", @INC;
+ # translate any SAMEPERL in cmd to $this_perl
+ $_ 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.
# limit various forms of insanity, for now
local $ENV{DBI_TRACE};
@@ -37,7 +48,7 @@
my ($wfh, $rfh, $efh) = (gensym, gensym, gensym);
my $pid = open3($wfh, $rfh, $efh, @$cmd)
- or die "error starting $cmd: $!\n";
+ or die "error starting @$cmd: $!\n";
$self->trace_msg("Started pid $pid: $cmd\n") if $self->trace;
return {
@@ -63,7 +74,7 @@
my $info = eval {
my $frozen_request = $self->freeze_data($request);
- my $cmd = [qw(perl -MDBI::Gofer::Transport::pipeone -e run_one_stdio)];
+ my $cmd = [ qw(SAMEPERL -MDBI::Gofer::Transport::pipeone -e
run_one_stdio)];
my $info = $self->start_pipe_command($cmd);
my $wfh = delete $info->{wfh};
@@ -71,7 +82,7 @@
print $wfh $frozen_request;
# indicate that there's no more
close $wfh
- or die "error writing to $cmd: $!\n";
+ or die "error writing to @$cmd: $!\n";
$info; # so far so good. return the state info
};
@@ -97,7 +108,7 @@
return $response if $response; # failed while starting
my $info = $self->connection_info || die;
- my ($pid, $rfh, $efh) = @{$info}{qw(pid rfh efh)};
+ my ($pid, $rfh, $efh, $cmd) = @{$info}{qw(pid rfh efh cmd)};
waitpid $info->{pid}, 0
or warn "waitpid: $!"; # XXX do something more useful?
@@ -108,14 +119,18 @@
if (not $frozen_response) { # no output on stdout at all
return DBI::Gofer::Response->new({
err => 1,
- errstr => "pipeone command failed: $stderr_msg",
+ errstr => ref($self)." command (@$cmd) failed: $stderr_msg",
});
}
- warn "STDERR message: $stderr_msg" if $stderr_msg; # XXX do something more
useful
# XXX need to be able to detect and deal with corruption
$response = $self->thaw_data($frozen_response);
+ if ($stderr_msg) {
+ warn "STDERR message from @$cmd: $stderr_msg"; # XXX remove later
+ $response->add_err(0, $stderr_msg);
+ }
+
return $response;
}
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 Sun Feb 18 08:35:38 2007
@@ -30,7 +30,7 @@
my $connection = $self->connection_info;
if (not $connection || ($connection->{pid} && not kill 0,
$connection->{pid})) {
- my $cmd = [qw(perl -MDBI::Gofer::Transport::stream -e
run_stdio_hex)];
+ 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"
@@ -39,6 +39,7 @@
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
Modified: dbi/trunk/t/85gofer.t
==============================================================================
--- dbi/trunk/t/85gofer.t (original)
+++ dbi/trunk/t/85gofer.t Sun Feb 18 08:35:38 2007
@@ -31,10 +31,16 @@
unless $0 =~ /\bzv/; # don't warn for t/zvg_85gofer.t
}
+# ensure subprocess (for pipeone and stream transport) will use the same
modules as us, ie ./blib
+local $ENV{PERL5LIB} = join ":", @INC;
+
+
+# XXX add way for a transport to be tested with multiple dsns
my $username = getpwuid($>);
my %transports = (
null => {},
pipeone => {},
+ stream => {},
# stream => { url => "ssh:[EMAIL PROTECTED]" },
http => { url => "http://localhost:8001/gofer"; },
);
@@ -88,7 +94,7 @@
$dsn = $remote_dsn if $transport eq 'no';
print " $dsn\n";
- my $dbh = DBI->connect($dsn, undef, undef, { HandleError => sub { print
$_[0]; 1 } } );
+ my $dbh = DBI->connect($dsn, undef, undef, { } );
ok $dbh, 'should connect';
die "$test_run_tag aborted\n" unless $dbh;
@@ -100,8 +106,10 @@
ok $dbh->do("CREATE TABLE fruit (dKey INT, dVal VARCHAR(10))");
die "$test_run_tag aborted\n" if $DBI::err;
- my $sth;
- $sth = $dbh->prepare("complete non-sql gibberish");
+ my $sth = do {
+ local $dbh->{PrintError} = 0;
+ $dbh->prepare("complete non-sql gibberish");
+ };
($policy->skip_prepare_check)
? isa_ok $sth, 'DBI::st'
: is $sth, undef, 'should detect prepare failure';
