Author: timbo
Date: Thu Feb 1 15:38:56 2007
New Revision: 8782
Modified:
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/Gofer.pm
dbi/trunk/lib/DBD/Gofer/Transport/pipeone.pm
dbi/trunk/lib/DBD/Gofer/Transport/pipestream.pm
dbi/trunk/lib/DBI/Gofer/Execute.pm
dbi/trunk/lib/DBI/Gofer/Response.pm
dbi/trunk/lib/DBI/Gofer/Transport/pipestream.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/09trace.t
Log:
Factory methods (ie connect & prepare) copy error/warn/info to their parent
handle (drh,dbh)
Matured pipwone and pipestream transports significantly.
Added some DBD::Gofer docs.
Warnings ($SIG{__WARN__}) are now caught by DBI::Gofer::Execute, included in
the response, and repeated by DBD::Gofer.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Thu Feb 1 15:38:56 2007
@@ -391,8 +391,8 @@
swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] },
},
dr => { # Database Driver Interface
- 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3
},
- 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3
},
+ 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'],
H=>3, O=>0x8000 },
+ 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'],
H=>3, O=>0x8000 },
'disconnect_all'=>{ U =>[1,1], O=>0x0800 },
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800 },
default_user => { U =>[3,4,'$user, $pass [, \%attr]' ] },
@@ -401,15 +401,15 @@
data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 },
take_imp_data => { U =>[1,1], },
clone => { U =>[1,2,'[\%attr]'] },
- connected => undef,
+ connected => { U =>[1,0], O => 0x0004 },
begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400 },
commit => { U =>[1,1], O=>0x0480|0x0800 },
rollback => { U =>[1,1], O=>0x0480|0x0800 },
'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ]
]'], O=>0x3200 },
last_insert_id => { U =>[5,6,'$catalog, $schema, $table_name,
$field_name [, \%attr ]'], O=>0x2800 },
preparse => { }, # XXX
- prepare => { U =>[2,3,'$statement [, \%attr]'],
O=>0x2200 },
- prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ]
]'], O=>0x2200 },
+ prepare => { U =>[2,3,'$statement [, \%attr]'],
O=>0xA200 },
+ prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ]
]'], O=>0xA200 },
selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ]
]'], O=>0x2000 },
selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ]
]'], O=>0x2000 },
selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ]
]'], O=>0x2000 },
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Thu Feb 1 15:38:56 2007
@@ -80,7 +80,7 @@
static int quote_type _((int sql_type, int p, int s, int *base_type, void
*v));
static int dbi_hash _((const char *string, long i));
static void dbih_dumphandle _((SV *h, const char *msg, int level));
-static void dbih_dumpcom _((imp_xxh_t *imp_xxh, const char *msg, int
level));
+static int dbih_dumpcom _((imp_xxh_t *imp_xxh, const char *msg, int
level));
char *neatsvpv _((SV *sv, STRLEN maxlen));
SV * preparse(SV *dbh, const char *statement, IV ps_return, IV ps_accept, void
*foo);
@@ -119,6 +119,7 @@
#define IMA_EXECUTE 0x1000 /* do/execute: DBIcf_Executed */
#define IMA_SHOW_ERR_STMT 0x2000 /* dbh meth relates to Statement*/
#define IMA_HIDE_ERR_PARAMVALUES 0x4000 /* ParamValues are not relevant
*/
+#define IMA_IS_FACTORY 0x8000 /* new h ie connect and prepare */
#define DBIc_STATE_adjust(imp_xxh, state) \
(SvOK(state) /* SQLSTATE is implemented by driver */ \
@@ -207,6 +208,10 @@
return buf;
}
+/* handy for embedding into condition expression for debugging */
+static int warn1(char *s) { warn(s); return 1; }
+static int dump1(SV *sv) { dTHX; sv_dump(sv); return 1; }
+
/* --- */
@@ -1183,7 +1188,7 @@
dbih_dumpcom(imp_xxh, msg, level);
}
-static void
+static int
dbih_dumpcom(imp_xxh_t *imp_xxh, const char *msg, int level)
{
dTHX;
@@ -1218,10 +1223,15 @@
if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile ");
if (DBIc_is(imp_xxh, DBIcf_Callbacks)) sv_catpv(flags,"Callbacks ");
PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad,
(long)DBIc_FLAGS(imp_xxh), SvPV(flags,lna));
+ if (SvOK(DBIc_ERR(imp_xxh)))
+ PerlIO_printf(DBILOGFP,"%s ERR %s\n", pad,
neatsvpv((SV*)DBIc_ERR(imp_xxh),0));
+ if (SvOK(DBIc_ERR(imp_xxh)))
+ PerlIO_printf(DBILOGFP,"%s ERRSTR %s\n", pad,
neatsvpv((SV*)DBIc_ERRSTR(imp_xxh),0));
PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad,
neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0));
PerlIO_printf(DBILOGFP,"%s KIDS %ld (%ld Active)\n", pad,
(long)DBIc_KIDS(imp_xxh), (long)DBIc_ACTIVE_KIDS(imp_xxh));
- PerlIO_printf(DBILOGFP,"%s IMP_DATA %s\n", pad,
neatsvpv(DBIc_IMP_DATA(imp_xxh),0));
+ if (DBIc_IMP_DATA(imp_xxh) && SvOK(DBIc_IMP_DATA(imp_xxh)))
+ PerlIO_printf(DBILOGFP,"%s IMP_DATA %s\n", pad,
neatsvpv(DBIc_IMP_DATA(imp_xxh),0));
if (DBIc_LongReadLen(imp_xxh) != DBIc_LongReadLen_init)
PerlIO_printf(DBILOGFP,"%s LongReadLen %ld\n", pad,
(long)DBIc_LongReadLen(imp_xxh));
@@ -1246,6 +1256,7 @@
PerlIO_printf(DBILOGFP,"%s '%s' => %s\n", pad, key,
neatsvpv(value,0));
}
}
+ return 1;
}
@@ -2912,7 +2923,7 @@
if (!keep_error && !(*meth_name=='s' && strEQ(meth_name,"set_err"))) {
SV *err_sv;
- if (trace_level >= 4 && SvOK(err_sv=DBIc_ERR(imp_xxh))) {
+ if (trace_level && SvOK(err_sv=DBIc_ERR(imp_xxh))) {
PerlIO *logfp = DBILOGFP;
PerlIO_printf(logfp, " !! %s: %s CLEARED by call to %s method\n",
SvTRUE(err_sv) ? "ERROR" : strlen(SvPV_nolen(err_sv)) ? "warn"
: "info",
@@ -3060,9 +3071,9 @@
}
SPAGAIN;
- if (trace_level) { /* XXX restore local vars so ST(n) works below
*/
- sp -= outitems; ax = (sp - stack_base) + 1;
- }
+ /* XXX restore local vars so ST(n) works below */
+ sp -= outitems;
+ ax = (sp - stack_base) + 1;
#ifdef DBI_save_hv_fetch_ent
if (is_FETCH)
@@ -3232,6 +3243,14 @@
}
}
+ if (ima_flags & IMA_IS_FACTORY && SvROK(ST(0))) {
+ SV *h_new = ST(0);
+ D_impdata(imp_xxh_new, imp_xxh_t, h_new);
+ if (SvOK(DBIc_ERR(imp_xxh_new))) {
+ set_err_sv(h, imp_xxh, DBIc_ERR(imp_xxh_new),
DBIc_ERRSTR(imp_xxh_new), DBIc_STATE(imp_xxh_new), &sv_no);
+ }
+ }
+
if ( !keep_error /* is a new err/warn/info
*/
&& call_depth <= 1 /* skip nested (internal) calls
*/
&& (
Modified: dbi/trunk/lib/DBD/Gofer.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer.pm (original)
+++ dbi/trunk/lib/DBD/Gofer.pm Thu Feb 1 15:38:56 2007
@@ -69,10 +69,20 @@
$drh;
}
+
sub CLONE {
undef $drh;
}
+
+ sub set_err_from_response {
+ my ($h, $response) = @_;
+ # set error/warn/info
+ my $warnings = $response->warnings || [];
+ warn $_ for @$warnings;
+ return $h->set_err($response->err, $response->errstr,
$response->state);
+ }
+
}
@@ -119,7 +129,7 @@
or return $drh->set_err(1, "No transport= argument in
'$orig_dsn'");
$transport_class = "DBD::Gofer::Transport::$dsn_attr{go_transport}"
unless $transport_class =~ /::/;
- eval "require $transport_class" # XXX fix unsafe string eval
+ _load_class($transport_class)
or return $drh->set_err(1, "Error loading $transport_class: $@");
my $go_trans = eval { $transport_class->new(\%dsn_attr) }
or return $drh->set_err(1, "Error instanciating $transport_class:
$@");
@@ -158,6 +168,17 @@
}
sub DESTROY { undef }
+
+
+ sub _load_class { # return true or false+$@
+ my $class = shift;
+ (my $pm = $class) =~ s{::}{/}g;
+ $pm .= ".pm";
+ return 1 if eval { require $pm };
+ delete $INC{$pm}; # shouldn't be needed (perl bug?) and assigning
undef isn't enough
+ undef; # error in $@
+ }
+
}
@@ -198,7 +219,7 @@
$rv = [ $sth ];
}
- $dbh->set_err($response->err, $response->errstr, $response->state);
+ DBD::Gofer::set_err_from_response($dbh, $response);
return (wantarray) ? @$rv : $rv->[0];
}
@@ -362,12 +383,11 @@
$sth->{go_rows} = $response->rv;
}
# set error/warn/info (after more_results as that'll clear err)
- $sth->set_err($response->err, $response->errstr, $response->state);
+ DBD::Gofer::set_err_from_response($sth, $response);
return $response->rv;
}
-
# sth methods that should always fail, at least for now
for my $method (qw(
bind_param_inout bind_param_array bind_param_inout_array execute_array
execute_for_fetch
@@ -479,15 +499,21 @@
use DBI;
- $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$dsn",
+ $original_dsn = "dbi:..."; # your original DBI Data Source Name
+
+ $dbh = DBI->connect("dbi:Gofer:transport=$transport;...;dsn=$original_dsn",
$user, $passwd, \%attributes);
+ ... use $dbh as if it was connected to $original_dsn ...
+
+
The C<transport=$transport> part specifies the name of the module to use to
transport the requests to the remote DBI. If $transport doesn't contain any
double colons then it's prefixed with C<DBD::Gofer::Transport::>.
-The C<dsn=$dsn> part I<must> be the last element of the dsn because everything
-after C<dsn=> is assumed to be the DSN that the remote DBI should use.
+The C<dsn=$original_dsn> part I<must be the last element> of the DSN because
+everything after C<dsn=> is assumed to be the DSN that the remote DBI should
+use.
The C<...> represents attributes that influence the operation of the Gofer
driver or transport. These are described below or in the documentation of the
@@ -495,13 +521,15 @@
=head1 DESCRIPTION
-DBD::Gofer is a DBI database driver that forwards requests to another DBI
driver,
-usually in a seperate process, often on a separate machine.
-
-It is very similar to DBD::Proxy. The major difference is that DBD::Gofer
-assumes no state is maintained on the remote end. That means every request
-contains all the information needed to create the required state. (So, for
-example, every request includes the DSN to connect to.) Each request can be
+DBD::Gofer is a DBI database driver that forwards requests to another DBI
+driver, usually in a seperate process, often on a separate machine. It tries to
+be as transparent as possible so it appears that you are using the remote
+driver directly.
+
+DBD::Gofer is very similar to DBD::Proxy. The major difference is that with
+DBD::Gofer no state is maintained on the remote end. That means every
+request contains all the information needed to create the required state. (So,
+for example, every request includes the DSN to connect to.) Each request can be
sent to any available server. The server executes the request and returns a
single response that includes all the data.
@@ -549,8 +577,7 @@
=head3 Thin Clients / Unsupported Platforms
-You no longer need drivers for your database on every system.
-DBD::Gofer is pure perl
+You no longer need drivers for your database on every system. DBD::Gofer is
pure perl.
=head1 CONSTRAINTS
@@ -564,42 +591,128 @@
This is because it's critical that when a request is complete the database
handle is left in the same state it was when first connected.
-=head2 AutoCommit only
+=head2 You can't use transactions.
-Transactions aren't supported.
+AutoCommit only. Transactions aren't supported.
-=head1 CAVEATS
+=head2 You need to use func() to call driver-private dbh methods
-A few things to keep in mind when using DBD::Gofer:
+So instead of the new-style:
-=head2 Driver-private Methods
+ $dbh->foo_method_name(...)
-These can be called via the func() method on the dbh
-but not the sth.
+you need to use the old-style:
-=head2 Driver-private Statement Handle Attributes
+ $dbh->func(..., 'foo_method_name');
-Driver-private sth attributes can be set in the prepare() call. XXX
+This constraint might be removed in future.
-Driver-private sth attributes can't be read, currently. In future it will be
-possible to indicate which sth attributes you'd like to be able to read.
+=head2 You can't call driver-private sth methods
-=head1 Array Methods
+But few people need to do that.
+
+=head2 Array Methods are not supported
The array methods (bind_param_inout bind_param_array bind_param_inout_array
execute_array execute_for_fetch)
are not currently supported. Patches welcome, of course.
+=head1 CAVEATS
+
+A few things to keep in mind when using DBD::Gofer:
+
+=head2 Driver-private Database Handle Attributes
+
+Some driver-private dbh attributes may not be available, currently.
+In future it will be possible to indicate which attributes you'd like to be
+able to read.
+
+=head2 Driver-private Statement Handle Attributes
+
+Driver-private sth attributes can be set in the prepare() call. TODO
+
+Some driver-private sth attributes may not be available, currently.
+In future it will be possible to indicate which attributes you'd like to be
+able to read.
+
=head1 Multiple Resultsets
Multiple resultsets are supported if the driver supports the more_results()
method.
+=head1 TRANSPORTS
+
+DBD::Gofer doesn't concern itself with transporting requests and responses to
and fro.
+For that it uses special Gofer transport modules.
+
+Gofer transport modules usually come in pairs: one for the 'client' DBD::Gofer
+driver to use and one for the remote 'server' end. They have very similar
names:
+
+ DBD::Gofer::Transport::<foo>
+ DBI::Gofer::Transport::<foo>
+
+Several transport modules are provided with DBD::Gofer:
+
+=head2 null
+
+The null transport is the simplest of them all. It doesn't actually transport
the request anywhere.
+It just serializes (freezes) the request into a string, then thaws it back into
+a data structure before passing it to DBI::Gofer::Execute to execute. The same
+freeze and thaw is applied to the results.
+
+The null transport is the best way to test if your application will work with
Gofer.
+Just set the DBI_AUTOPROXY environment variable to
"C<dbi:Gofer:transport=null>"
+(see L</DBI_AUTOPROXY> below) and run your application, or ideally its test
suite, as usual.
+
+It doesn't take any parameters.
+
+=head2 pipeone
+
+The pipeone transport launches a subprocess for each request. It passes in the
+request and reads the response. The fact that a new subprocess is started for
+each request proves that the server side is truely stateless. It also makes
+this transport very slow. It's useful, however, both as a proof of concept and
+as a base class for the stream driver.
+
+It doesn't take any parameters.
+
+=head2 stream
+
+The stream driver also launches a subprocess and writes requests and reads
+responses, like the pipeone transport. In this case, however, the subprocess
+is expected to handle more that one request. (Though it will be restarted if
it exits.)
+
+This is the first transport that is truly useful because it can launch the
+subprocess using ssh. This means you can now use DBD::Gofer to easily access
+any databases that's accessible from any system you can login to.
+
+XXX ssh
+
+=head2 http
+
+The http driver uses the http protocol to send Gofer requests and receive
replies.
+
+XXX not yet implemented
+
=head1 CONNECTING
+Simply prefix your existing DSN with "C<dbi:Gofer:transport=$transport;dsn=>"
+where $transport is the name of the Gofer transport you want to use (see
L</TRANSPORTS>).
+The C<transport> and C<dsn> attributes must be specified and the C<dsn>
attributes must be last.
+
+Other attributes can be specified in the DSN to configure DBD::Gofer and/or
the transport being used.
+
XXX
=head2 Using DBI_AUTOPROXY
-XXX
+The simplest way to try out DBD::Gofer is to set the DBI_AUTOPROXY environment
variable.
+In this case you don't include the C<dsn=> part.
+
+ export DBI_AUTOPROXY=dbi:Gofer:transport=null
+
+or
+
+ export DBI_AUTOPROXY=dbi:Gofer:transport=stream;[EMAIL PROTECTED]
+
=head1 CONFIGURING VIA POLICY
@@ -607,11 +720,11 @@
=head1 AUTHOR AND COPYRIGHT
-The DBI module is Copyright (c) 2007 Tim Bunce. Ireland.
-All rights reserved.
-
-You may distribute under the terms of either the GNU General Public
-License or the Artistic License, as specified in the Perl README file.
+The DBD::Gofer, DBD::Gofer::* and DBI::Gofer::* modules are
+Copyright (c) 2007 Tim Bunce. Ireland. All rights reserved.
+
+You may distribute under the terms of either the GNU General Public License or
+the Artistic License, as specified in the Perl README file.
=head1 SEE ALSO
@@ -622,7 +735,7 @@
=head1 TODO
-dbh STORE doesn't record set attributes
+Test existing compiled drivers (ie DBD::mysql) for binary compatibility
Driver-private sth attributes - set via prepare() - change DBI spec
Auto-configure based on driver name.
@@ -634,8 +747,6 @@
Driver-private sth methods via func? Can't be sure of state?
-Sybase specific features.
-
XXX track installed_methods and install proxies on client side after connect?
XXX add hooks into transport base class for checking & updating a cache
@@ -652,6 +763,10 @@
check clone tests
-add early test that connected dbh is active
+Add policy mechanism
+
+Add mecahism for transports to list config params
+and for Gofer to apply any that match
+(and warn if any left over?)
=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 Thu Feb 1 15:38:56 2007
@@ -25,6 +25,7 @@
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;
@@ -35,7 +36,7 @@
local $ENV{DBI_PROFILE};
my ($wfh, $rfh, $efh) = (gensym, gensym, gensym);
- my $pid = open3($wfh, $rfh, $efh, $cmd)
+ my $pid = open3($wfh, $rfh, $efh, @$cmd)
or die "error starting $cmd: $!\n";
warn "Started pid $pid: $cmd\n" if $self->trace;
@@ -47,13 +48,22 @@
}
+sub cmd_as_string {
+ my $self = shift;
+ # XXX meant to return a prroperly shell-escaped string suitable for system
+ # but its only for debugging so that can wait
+ my $connection_info = $self->connection_info;
+ return join " ", @{$connection_info->{cmd}};
+}
+
+
sub transmit_request {
my ($self, $request) = @_;
my $info = eval {
my $frozen_request = $self->freeze_data($request);
- my $cmd = "perl -MDBI::Gofer::Transport::pipeone -e run_one_stdio";
+ my $cmd = [qw(perl -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/pipestream.pm
==============================================================================
--- dbi/trunk/lib/DBD/Gofer/Transport/pipestream.pm (original)
+++ dbi/trunk/lib/DBD/Gofer/Transport/pipestream.pm Thu Feb 1 15:38:56 2007
@@ -17,6 +17,10 @@
our $VERSION = sprintf("0.%06d", q$Revision: 8748 $ =~ /(\d+)/o);
+__PACKAGE__->mk_accessors(qw(
+ ssh
+));
+
sub nonblock;
@@ -27,8 +31,15 @@
my $connection = $self->connection_info;
if (not $connection || ($connection->{pid} && not kill 0,
$connection->{pid})) {
- my $cmd = "perl -MDBI::Gofer::Transport::pipestream -e
run_stdio_hex";
- #$cmd = "DBI_TRACE=2=/tmp/pipestream.log $cmd";
+ my $cmd = [qw(perl -MDBI::Gofer::Transport::pipestream -e
run_stdio_hex)];
+ #push @$cmd, "DBI_TRACE=2=/tmp/pipestream.log", "sh", "-c";
+ if (0) {
+ my $ssh = '[EMAIL PROTECTED]';
+ unshift @$cmd, 'ssh', '-q', split(' ', $ssh);
+ }
+ # XXX add a handshake - some message from
DBI::Gofer::Transport::pipestream 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);
@@ -65,25 +76,35 @@
my $connection = $self->connection_info || die;
my ($pid, $rfh, $efh) = @{$connection}{qw(pid rfh efh)};
+ # blocks till a newline has been read
my $frozen_response = <$rfh>; # always one line
- my $stderr_msg = do { local $/; <$efh> }; # nonblocking
-
- chomp $stderr_msg if $stderr_msg;
+ my $frozen_response_errno = $!;
- if (not $frozen_response) { # no output on stdout at all
- warn "STDERR err message: $stderr_msg" if $stderr_msg; # XXX do something
more useful
- return DBI::Gofer::Response->new({
- err => 1,
- errstr => "Error reading from $connection->{cmd}: $stderr_msg",
- });
+ # must read any stderr output _afterwards_
+ # warnings during execution are caught and returned as part
+ # of the response object. So stderr should be silent.
+ 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.
+ # 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 });
}
- chomp $frozen_response if $frozen_response;
- warn "STDERR additional message: $stderr_msg" if $stderr_msg; # XXX do
something more useful
#warn DBI::neat($frozen_response);
+ warn "pipestream stderr message: $stderr_msg\n" if $stderr_msg &&
$self->trace;
# XXX need to be able to detect and deal with corruption
$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)
+ if $stderr_msg;
+
return $response;
}
Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm Thu Feb 1 15:38:56 2007
@@ -155,6 +155,8 @@
my $request = shift;
local $recurse = $recurse + 1;
warn "Gofer request level $recurse\n" if $trace;
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, @_ };
# guaranteed not to throw an exception
my $response = eval {
($request->is_sth_request)
@@ -162,13 +164,13 @@
: execute_dbh_request($request);
};
if ($@) {
- warn $@; # XXX
chomp $@;
$response = DBI::Gofer::Response->new({
err => 1, errstr => $@, state => '',
});
}
#warn "Gofer response level $recurse: ".$response->rv."\n" if $trace;
+ $response->warnings([EMAIL PROTECTED]) if @warnings;
return $response;
}
Modified: dbi/trunk/lib/DBI/Gofer/Response.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Response.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Response.pm Thu Feb 1 15:38:56 2007
@@ -18,6 +18,50 @@
state
last_insert_id
sth_resultsets
+ warnings
));
+
+sub add_err {
+ my ($self, $err, $errstr, $state, $trace) = @_;
+ chomp $errstr if $errstr;
+ $state ||= '';
+ warn "add_err($err, $errstr, $state)" if $trace and $errstr || $err;
+
+ # acts like the DBI's set_err method.
+ # this code copied from DBI::PurePerl's set_err method.
+
+ my ($r_err, $r_errstr, $r_state) = ($self->{err}, $self->{errstr},
$self->{state});
+
+ if ($r_errstr) {
+ $r_errstr .= sprintf " [err was %s now %s]", $r_err, $err
+ if $r_err && $err;
+ $r_errstr .= sprintf " [state was %s now %s]", $r_state, $state
+ if $r_state and $r_state ne "S1000" && $state;
+ $r_errstr .= "\n$errstr";
+ }
+ else {
+ $r_errstr = $errstr;
+ }
+
+ # assign if higher priority: err > "0" > "" > undef
+ my $err_changed;
+ if ($err # new error: so assign
+ or !defined $r_err # no existing warn/info: so assign
+ # new warn ("0" len 1) > info ("" len 0): so assign
+ or defined $err && length($err) > length($r_err)
+ ) {
+ $r_err = $err;
+ ++$err_changed;
+ }
+
+ $r_state = ($state eq "00000") ? "" : $state
+ if $state && $err_changed;
+
+ ($self->{err}, $self->{errstr}, $self->{state}) = ($r_err, $r_errstr,
$r_state);
+
+ return undef;
+}
+
+
1;
Modified: dbi/trunk/lib/DBI/Gofer/Transport/pipestream.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/pipestream.pm (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/pipestream.pm Thu Feb 1 15:38:56 2007
@@ -24,6 +24,8 @@
my $self = DBI::Gofer::Transport::pipestream->new();
local $| = 1;
+ #warn "STARTED $$";
+
while ( my $frozen_request = <STDIN> ) {
my $request = $self->thaw_data( pack "H*", $frozen_request );
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Thu Feb 1 15:38:56 2007
@@ -130,6 +130,7 @@
use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */
use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/
use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not
relevant */
+use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */
my %is_flag_attribute = map {$_ =>1 } qw(
Active
@@ -320,6 +321,13 @@
} if IMA_END_WORK & $bitmask;
push @post_call_frag, q{
+ if ( ref $ret[0] and defined( (my $h_new = $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})
+ }
+ } if IMA_IS_FACTORY & $bitmask;
+
+ push @post_call_frag, q{
$keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;
$DBI::err = $h->{err};
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Thu Feb 1 15:38:56 2007
@@ -98,7 +98,7 @@
print "test unknown parse_trace_flag\n";
my $warn = 0;
local $SIG{__WARN__} = sub {
- if ($_[0] =~ /unknown/i) { ++$warn; print "warn: ",@_ }else{ warn @_ }
+ if ($_[0] =~ /unknown/i) { ++$warn; print "caught warn: ",@_ }else{
warn @_ }
};
is $dbh->parse_trace_flag("nonesuch"), undef;
is $warn, 0;
