Author: timbo
Date: Sun Feb 22 10:33:47 2004
New Revision: 129
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/06attrs.t
dbi/trunk/t/80proxy.t
Log:
Use rise in ErrCount to detect errors in cases where err was not cleared
(errors during FETCH and STORE are now detected as expected, if driver uses set_err)
Improve tracing of install_method.
Undo previous change to table_info param checking (too many places call it with no
args).
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Sun Feb 22 10:33:47 2004
@@ -26,7 +26,7 @@
so that fetchall_arrayref(), for example, doesn't flood the trace.
Changed trace level to be a four bit integer (levels 0 thru 15)
and a set of topic flags (no topics have been assigned yet).
- Change table_info() and column_info() to check argument count.
+ Changed column_info() to check argument count.
Extended bind_param() TYPE attribute specification to imply
standard formating of value, eg SQL_DATE implies 'YYYY-MM-DD'.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Sun Feb 22 10:33:47 2004
@@ -408,7 +408,7 @@
rows => $keeperr,
tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x0200 },
- table_info => { U =>[5,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x0200|0x0800 },
+ table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]'
], O=>0x0200|0x0800 },
column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr
]'],O=>0x0200|0x0800 },
primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x0200|0x0800 },
primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ],
O=>0x0200 },
@@ -1500,7 +1500,7 @@
sub tables {
my ($dbh, @args) = @_;
- my $sth = $dbh->table_info(@args) or return;
+ my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return;
my $tables = $sth->fetchall_arrayref or return;
my @tables;
if ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Sun Feb 22 10:33:47 2004
@@ -2228,6 +2228,7 @@
int is_DESTROY;
int is_FETCH;
int keep_error = FALSE;
+ UV ErrCount = ~0;
int i, outitems;
int call_depth;
double profile_t1 = 0.0;
@@ -2492,6 +2493,8 @@
}
DBIh_CLEAR_ERROR(imp_xxh);
}
+ else /* we check for change in ErrCount during call */
+ ErrCount = DBIc_ErrCount(imp_xxh);
/* The "quick_FETCH" logic... */
/* Shortcut for fetching attributes to bypass method call overheads */
@@ -2626,6 +2629,11 @@
post_dispatch:
+ /* 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)
+ keep_error = 0;
+
err_sv = DBIc_ERR(imp_xxh);
if (trace_level >= 1
@@ -3407,21 +3415,21 @@
{
dPERINTERP;
/* install another method name/interface for the DBI dispatcher */
- int debug = (DBIS_TRACE_LEVEL >= 10);
+ SV *trace_msg = (DBIS_TRACE_LEVEL >= 10) ? sv_2mortal(newSVpv("",0)) : Nullsv;
CV *cv;
SV **svp;
dbi_ima_t *ima = NULL;
dbi_class = dbi_class; /* avoid 'unused variable' warning */
- if (debug)
- PerlIO_printf(DBILOGFP,"install_method %s\t", meth_name);
-
if (strnNE(meth_name, "DBI::", 5)) /* XXX m/^DBI::\w+::\w+$/ */
- croak("install_method: invalid name '%s'", meth_name);
+ croak("install_method %s: invalid class", meth_name);
- if (attribs && SvROK(attribs)) {
- SV *sv;
+ if (trace_msg)
+ sv_catpvf(trace_msg, "install_method %-21s", meth_name);
+
+ if (attribs && SvOK(attribs)) {
/* convert and store method attributes in a fast access form */
+ SV *sv;
if (SvTYPE(SvRV(attribs)) != SVt_PVHV)
croak("install_method %s: bad attribs", meth_name);
@@ -3432,6 +3440,11 @@
DBD_ATTRIB_GET_IV(attribs, "T",1, svp, ima->trace_level);
DBD_ATTRIB_GET_IV(attribs, "H",1, svp, ima->hidearg);
+ if (trace_msg) {
+ if (ima->flags) sv_catpvf(trace_msg, ", flags 0x%04x", ima->flags);
+ if (ima->trace_level) sv_catpvf(trace_msg, ", T %d", ima->trace_level);
+ if (ima->hidearg) sv_catpvf(trace_msg, ", H %d", ima->hidearg);
+ }
if ( (svp=DBD_ATTRIB_GET_SVP(attribs, "U",1)) != NULL) {
STRLEN lna;
AV *av = (AV*)SvRV(*svp);
@@ -3440,20 +3453,15 @@
svp = av_fetch(av, 2, 0);
ima->usage_msg = savepv( (svp) ? SvPV(*svp,lna) : "");
ima->flags |= IMA_HAS_USAGE;
- if (debug)
- PerlIO_printf(DBILOGFP," usage: min %d, max %d, '%s', tl %d\n",
- ima->minargs, ima->maxargs, ima->usage_msg, ima->trace_level);
+ if (trace_msg && DBIS_TRACE_LEVEL >= 11)
+ sv_catpvf(trace_msg, ",\n usage: min %d, max %d, '%s'",
+ ima->minargs, ima->maxargs, ima->usage_msg);
}
- if (debug)
- PerlIO_printf(DBILOGFP,", flags 0x%x", ima->flags);
-
- } else if (attribs && SvOK(attribs)) {
- croak("install_method %s: attributes not a ref", meth_name);
}
+ if (trace_msg)
+ PerlIO_printf(DBILOGFP,"%s\n", SvPV_nolen(trace_msg));
cv = newXS(meth_name, XS_DBI_dispatch, file);
CvXSUBANY(cv).any_ptr = ima;
- if (debug)
- PerlIO_printf(DBILOGFP,"\n");
ST(0) = &sv_yes;
}
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Sun Feb 22 10:33:47 2004
@@ -250,6 +250,10 @@
}
push @pre_call_frag, q{
+ my $ErrCount = $h->{ErrCount};
+ };
+
+ push @pre_call_frag, q{
if (($DBI::dbi_debug & 0xF) >= 2) {
local $^W;
my $args = join " ", map { DBI::neat($_) } ($h, @_);
@@ -283,6 +287,8 @@
} if IMA_END_WORK & $bitmask;
push @post_call_frag, q{
+ $keep_error = 0 if $keep_error && $h->{ErrCount} > $ErrCount;
+
if ( !$keep_error
&& defined(my $err = $h->{err})
&& ($call_depth <= 1 && !$h->{_parent}{_call_depth})
@@ -328,7 +334,7 @@
}
}
}
- } unless IMA_KEEP_ERR & $bitmask;
+ };
my $method_code = q[
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Sun Feb 22 10:33:47 2004
@@ -4,7 +4,7 @@
use Test::More;
use DBI;
-BEGIN { plan tests => 147 }
+BEGIN { plan tests => 149 }
$|=1;
@@ -123,7 +123,9 @@
ok( $dbh->{Executed} ); # due to $sth->prepare, even though it failed
is( $sth->{ErrCount}, 1 );
-$sth->{ErrCount} = 42;
+eval { $sth->{ErrCount} = 42 };
+ok($@);
+ok($@ =~ m/STORE failed:/);
is( $sth->{ErrCount}, 42 );
$sth->{ErrCount} = 0;
is( $sth->{ErrCount}, 0 );
Modified: dbi/trunk/t/80proxy.t
==============================================================================
--- dbi/trunk/t/80proxy.t (original)
+++ dbi/trunk/t/80proxy.t Sun Feb 22 10:33:47 2004
@@ -308,7 +308,7 @@
$dirs{$file} = 1 if -d $file;
}
closedir(DIR);
-my $sth = $dbh->table_info();
+my $sth = $dbh->table_info(undef, undef, undef, undef);
Test($sth) or warn "table_info failed: ", $dbh->errstr(), "\n";
%missing = %dirs;
%unexpected = ();
