Author: timbo
Date: Wed Dec 8 01:52:36 2004
New Revision: 603
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBD/ExampleP.pm
dbi/trunk/lib/DBD/NullP.pm
dbi/trunk/lib/DBD/Proxy.pm
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/10examp.t
Log:
Fixed setting $DBI::lasth where DESTROY calls other methods.
Fixed setting $DBI::err/errstr in DBI::PurePerl.
Fixed potential undef warning from connect_cached().
Fixed $DBI::lasth handling for DESTROY so lasth points to
parent even if DESTROY called other methods.
Changed error handling so undef errstr doesn't cause warning.
Changed DBI::DBD docs to use =head3/=head4 pod thanks to
Jonathan Leffler. This may generate warnings for perl 5.6.
Changed DBI::PurePerl to set autoflush on trace filehandle.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Wed Dec 8 01:52:36 2004
@@ -7,6 +7,16 @@
=head2 Changes in DBI 1.47 (svn rev XXX), XXth November 2004
Fixed some tests to work with older Test::More versions.
+ Fixed setting $DBI::lasth where DESTROY calls other methods.
+ Fixed setting $DBI::err/errstr in DBI::PurePerl.
+ Fixed potential undef warning from connect_cached().
+ Fixed $DBI::lasth handling for DESTROY so lasth points to
+ parent even if DESTROY called other methods.
+
+ Changed error handling so undef errstr doesn't cause warning.
+ Changed DBI::DBD docs to use =head3/=head4 pod thanks to
+ Jonathan Leffler. This may generate warnings for perl 5.6.
+ Changed DBI::PurePerl to set autoflush on trace filehandle.
Changed DBD::Proxy to treat Username as a local attribute
so recent DBI version can be used with old DBI::ProxyServer.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Wed Dec 8 01:52:36 2004
@@ -9,7 +9,7 @@
require 5.006_00;
BEGIN {
-$DBI::VERSION = "1.46"; # ==> ALSO update the version in the pod text below!
+$DBI::VERSION = "1.47"; # ==> ALSO update the version in the pod text below!
}
=head1 NAME
@@ -115,7 +115,7 @@
=head2 NOTES
-This is the DBI specification that corresponds to the DBI version 1.46.
+This is the DBI specification that corresponds to the DBI version 1.47.
The DBI is evolving at a steady pace, so it's good to check that
you have the latest copy.
@@ -1400,8 +1400,9 @@
$drh->STORE('CachedKids', $cache = {}) unless $cache;
my @attr_keys = $attr ? sort keys %$attr : ();
- my $key = join "~~", $dsn, $user||'', $auth||'',
- $attr ? (@attr_keys,@[EMAIL PROTECTED]) : ();
+ my $key = do { local $^W; # silence undef warnings
+ join "~~", $dsn, $user||'', $auth||'', $attr ? (@attr_keys,@[EMAIL
PROTECTED]) : ()
+ };
my $dbh = $cache->{$key};
if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) {
# XXX warn if BegunWork?
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Wed Dec 8 01:52:36 2004
@@ -1130,6 +1130,7 @@
int dump = FALSE;
int debug = DBIS_TRACE_LEVEL;
int auto_dump = (debug >= 6);
+ imp_xxh_t *parent_xxh = DBIc_PARENT_COM(imp_xxh);
/* Note that we're very much on our own here. DBIc_MY_H(imp_xxh) almost
*/
/* certainly points to memory which has been freed. Don't use it!
*/
@@ -1189,8 +1190,12 @@
/* --- pre-clearing adjustments --- */
- if (DBIc_PARENT_COM(imp_xxh) && !dirty) {
- --DBIc_KIDS(DBIc_PARENT_COM(imp_xxh));
+ if (!dirty) {
+ if (parent_xxh) {
+ if (DBIc_ACTIVE(imp_xxh)) /* see also DBIc_ACTIVE_off */
+ --DBIc_ACTIVE_KIDS(parent_xxh);
+ --DBIc_KIDS(parent_xxh);
+ }
}
/* --- clear fields (may invoke object destructors) --- */
@@ -2517,17 +2522,6 @@
clear_cached_kids(h, imp_xxh, meth_name, trace_flags);
}
- if (DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle */
- SV *lhp = DBIc_PARENT_H(imp_xxh);
- if (lhp && SvROK(lhp)) {
- DBI_SET_LAST_HANDLE(lhp);
- }
- else {
- DBI_UNSET_LAST_HANDLE;
- }
-
- } /* otherwise don't alter last handle */
-
if (DBIc_IADESTROY(imp_xxh)) { /* want's ineffective destroy */
DBIc_ACTIVE_off(imp_xxh);
}
@@ -2694,6 +2688,16 @@
post_dispatch:
+ if (is_DESTROY && DBI_IS_LAST_HANDLE(h)) { /* if destroying _this_ handle
*/
+ SV *lhp = DBIc_PARENT_H(imp_xxh);
+ if (lhp && SvROK(lhp)) {
+ DBI_SET_LAST_HANDLE(lhp);
+ }
+ else {
+ DBI_UNSET_LAST_HANDLE;
+ }
+ }
+
/* if we didn't clear err before the call, check if ErrCount has gone up */
/* if so, we turn off keep_error so error is acted on */
if (keep_error && DBIc_ErrCount(imp_xxh) > ErrCount)
@@ -2870,7 +2874,11 @@
sprintf(intro,"%s %s %s: ", HvNAME(DBIc_IMP_STASH(imp_xxh)),
err_meth_name,
SvTRUE(err_sv) ? "failed" : is_warning ? "warning" : "information");
msg = sv_2mortal(newSVpv(intro,0));
- sv_catsv(msg, DBIc_ERRSTR(imp_xxh));
+ if (SvOK(DBIc_ERRSTR(imp_xxh)))
+ sv_catsv(msg, DBIc_ERRSTR(imp_xxh));
+ else
+ sv_catpvf(msg, "(err=%s, errstr=undef, state=%s)",
+ neatsvpv(DBIc_ERR(imp_xxh),0), neatsvpv(DBIc_STATE(imp_xxh),0)
);
if ( DBIc_has(imp_xxh, DBIcf_ShowErrorStatement)
&& (DBIc_TYPE(imp_xxh) == DBIt_ST || ima_flags & IMA_SHOW_ERR_STMT)
Modified: dbi/trunk/lib/DBD/ExampleP.pm
==============================================================================
--- dbi/trunk/lib/DBD/ExampleP.pm (original)
+++ dbi/trunk/lib/DBD/ExampleP.pm Wed Dec 8 01:52:36 2004
@@ -403,7 +403,10 @@
return $sth->SUPER::STORE($attrib, $value);
}
- sub DESTROY { undef }
+ sub DESTROY {
+ my $sth = shift;
+ $sth->finish if $sth->SUPER::FETCH('Active');
+ }
*parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag;
}
Modified: dbi/trunk/lib/DBD/NullP.pm
==============================================================================
--- dbi/trunk/lib/DBD/NullP.pm (original)
+++ dbi/trunk/lib/DBD/NullP.pm Wed Dec 8 01:52:36 2004
@@ -107,10 +107,6 @@
return undef;
}
- sub finish {
- my($sth) = @_;
- }
-
sub FETCH {
my ($sth, $attrib) = @_;
# would normally validate and only fetch known attributes
Modified: dbi/trunk/lib/DBD/Proxy.pm
==============================================================================
--- dbi/trunk/lib/DBD/Proxy.pm (original)
+++ dbi/trunk/lib/DBD/Proxy.pm Wed Dec 8 01:52:36 2004
@@ -664,7 +664,8 @@
*bind_param_inout = \&bind_param;
sub DESTROY {
- # Just to avoid autoloading DESTROY ...
+ my $sth = shift;
+ $sth->finish if $sth->SUPER::FETCH('Active');
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Wed Dec 8 01:52:36 2004
@@ -36,6 +36,7 @@
$DBI::tfh = Symbol::gensym();
open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!";
+select( (select($DBI::tfh), $| = 1)[0] ); # autoflush
%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err);
@@ -308,6 +309,10 @@
push @post_call_frag, q{
$keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;
+ $DBI::err = $h->{err};
+ $DBI::errstr = $h->{errstr};
+ $DBI::state = $h->{state};
+
if ( !$keep_error
&& defined(my $err = $h->{err})
&& ($call_depth <= 1 && !$h->{_parent}{_call_depth})
@@ -336,7 +341,7 @@
}
$msg .= "]";
}
- if ($DBI::err eq "0") { # is 'warning' (not info)
+ if ($err eq "0") { # is 'warning' (not info)
carp $msg if $pw;
}
else {
@@ -401,7 +406,7 @@
warn "[EMAIL PROTECTED]" if $@;
die "[EMAIL PROTECTED]" if $@;
*$method = $code_ref;
- if (0 && $method =~ /set_err/) { # debuging tool
+ if (0 && $method =~ /do/) { # debuging tool
my $l=0; # show line-numbered code for method
warn "*$method = ".join("\n", map { ++$l.": $_" }
split/\n/,$method_code);
}
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Wed Dec 8 01:52:36 2004
@@ -11,7 +11,7 @@
require VMS::Filespec if $^O eq 'VMS';
# originally 246 tests
-use Test::More tests => 252;
+use Test::More tests => 253;
#use Test::More 'no_plan';
# "globals"
@@ -153,15 +153,16 @@
ok($@ =~ m/DBI commit: invalid number of arguments:/, $@)
unless $DBI::PurePerl && ok(1);
-ok($dbh->ping);
+ok($dbh->ping, "ping should return true");
# --- errors
my $cursor_e = $dbh->prepare("select unknown_field_name from ?");
-ok(!defined $cursor_e);
-ok($DBI::err);
-ok($DBI::errstr =~ m/Unknown field names: unknown_field_name/);
-ok($DBI::err == $dbh->err, "DBI::err='$DBI::err', dbh->err=".$dbh->err);
-ok($DBI::errstr eq $dbh->errstr, "DBI::errstr='$DBI::errstr',
dbh->errstr=".$dbh->errstr);
+is($cursor_e, undef, "prepare should fail");
+ok($dbh->err, "sth->err should be true");
+ok($DBI::err, "DBI::err should be true");
+cmp_ok($DBI::err, 'eq', $dbh->err , "\$DBI::err should match \$dbh->err");
+like($DBI::errstr, qr/Unknown field names: unknown_field_name/, "\$DBI::errstr
should contain error string");
+cmp_ok($DBI::errstr, 'eq', $dbh->errstr, "\$DBI::errstr should match
\$dbh->errstr");
# --- func
ok($dbh->errstr eq $dbh->func('errstr'));
