Author: timbo
Date: Sat Feb 21 15:19:10 2004
New Revision: 102
Modified:
dbi/trunk/Changes
dbi/trunk/DBI.pm
dbi/trunk/DBI.xs
dbi/trunk/DBIXS.h
dbi/trunk/Makefile.PL
dbi/trunk/lib/DBI/PurePerl.pm
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/06attrs.t
dbi/trunk/t/08keeperr.t
Log:
Add $h->{PrintWarn} attribute
Minor tweaks, including to set_err logic for state.
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Sat Feb 21 15:19:10 2004
@@ -4,7 +4,7 @@
=cut
-=head1 CHANGES in DBI 1.41, 17th February 2004
+=head1 CHANGES in DBI 1.41 (svn rev XX), 17th February 2004
Fixed execute_for_array() so tuple_status parameter is optional
as per docs, thanks to Ed Avis.
@@ -35,6 +35,8 @@
point that an error, warn, or info state is recorded.
The code can alter the err, errstr, and state values
(e.g., to promote an error to a warning, or the reverse).
+ Added $h->{PrintWarn} attribute to enable printing of warnings
+ recorded by the driver. Defaults to same value as $^W (perl -w).
Added $h->{Executed} attribute, set if do()/execute() called.
Added details of DBI::Const::GetInfoType module to get_info() docs.
Added ref count of inner handle to "DESTROY ignored for outer" msg.
Modified: dbi/trunk/DBI.pm
==============================================================================
--- dbi/trunk/DBI.pm (original)
+++ dbi/trunk/DBI.pm Sat Feb 21 15:19:10 2004
@@ -1300,7 +1300,7 @@
# attribute cache, i.e., boolean's and some others
$attr->{$_} = $old_dbh->FETCH($_) for (qw(
AutoCommit ChopBlanks InactiveDestroy
- LongTruncOk PrintError Profile RaiseError
+ LongTruncOk PrintError PrintWarn Profile RaiseError
ShowErrorStatement TaintIn TaintOut
));
}
@@ -2305,10 +2305,11 @@
(Oracle, for example, uses the ORACLE_SID and TWO_TASK environment
variables if no C<$data_source> is specified.)
-The C<AutoCommit> and C<PrintError> attributes for each connection default to
-"on". (See L</AutoCommit> and L</PrintError> for more information.)
+The C<AutoCommit> and C<PrintError> attributes for each connection
+default to "on". (See L</AutoCommit> and L</PrintError> for more information.)
However, it is strongly recommended that you explicitly define C<AutoCommit>
-rather than rely on the default.
+rather than rely on the default. The C<PrintWarn> attribute defaults to
+on if $^W is true, i.e., perl is running with warnings enabled.
The C<\%attr> parameter can be used to alter the default settings of
C<PrintError>, C<RaiseError>, C<AutoCommit>, and other attributes. For example:
@@ -2325,7 +2326,7 @@
You can also define connection attribute values within the C<$data_source>
parameter. For example:
- dbi:DriverName(PrintError=>0,Taint=>1):...
+ dbi:DriverName(PrintWarn=>1,PrintError=>0,Taint=>1):...
Individual attributes values specified in this way take precedence over
any conflicting values specified via the C<\%attr> parameter to C<connect>.
@@ -2354,7 +2355,7 @@
C<$dbh-E<gt>{PrintError}> attribute is off, and the old C<DBI_DBNAME>
environment variable is
checked if C<DBI_DSN> is not defined. Beware that this "old-style"
-C<connect> will be withdrawn in a future version of DBI.
+C<connect> will soon be withdrawn in a future version of DBI.
=item C<connect_cached>
@@ -2633,7 +2634,7 @@
after a method call. Similarly, a driver may return an empty string
to indicate a 'success with information' condition. In both these
cases the value is false but not undef. The errstr() and state()
-methods may be used to retrieve extra information.
+methods may be used to retrieve extra information in these cases.
See L</set_err> for more information.
@@ -2699,8 +2700,8 @@
of the values of the $errstr and $state parameters.
The $method parameter provides an alternate method name for the
-C<RaiseError>/C<PrintError> error string instead of the fairly
-unhelpful 'C<set_err>'.
+C<RaiseError>/C<PrintError>/C<PrintWarn> error string instead of
+the fairly unhelpful 'C<set_err>'.
The C<set_err> method normally returns undef. The $rv parameter
provides an alternate return value.
@@ -2824,10 +2825,13 @@
=item C<Warn> (boolean, inherited)
-The C<Warn> attribute enables useful warnings for certain bad practices. Enabled by
default. Some
-emulation layers, especially those for Perl 4 interfaces, disable warnings.
-Since warnings are generated using the Perl C<warn> function, they can be
-intercepted using the Perl C<$SIG{__WARN__}> hook.
+The C<Warn> attribute enables useful warnings for certain bad
+practices. It is enabled by default and should only be disable is
+rare circumstances. Since warnings are generated using the Perl
+C<warn> function, they can be intercepted using the Perl C<$SIG{__WARN__}>
+hook.
+
+The C<Warn> attribute is not related to the C<PrintWarn> attribute.
=item C<Active> (boolean, read-only)
@@ -2912,6 +2916,26 @@
level (not handle trace level) is set high enough to show the trace
from the DBI's method dispatcher, e.g. >= 9.
+=item C<PrintWarn> (boolean, inherited)
+
+The C<PrintWarn> attribute controls the printing of warnings recorded
+by the driver. When set to a true value the DBI will check method
+calls to see if a warning condition has been set. If so, the DBI
+will effectively do a C<warn("$class $method warning: $DBI::errstr")>
+where C<$class> is the driver class and C<$method> is the name of
+the method which failed. E.g.,
+
+ DBD::Oracle::db execute warning: ... warning text here ...
+
+By default, C<DBI-E<gt>connect> sets C<PrintWarn> "on" if $^W is true,
+i.e., perl is running with warnings enabled.
+
+If desired, the warnings can be caught and processed using a C<$SIG{__WARN__}>
+handler or modules like CGI::Carp and CGI::ErrorWrap.
+
+See also L</set_err> for how warnings are recorded and L</HandleSetErr>
+for how to influence it.
+
=item C<PrintError> (boolean, inherited)
The C<PrintError> attribute can be used to force errors to generate warnings (using
@@ -3047,7 +3071,7 @@
another DBI method. HandleSetErr, on the other hand, is called
whenever set_err() is called with a defined C<err> value, even if false.
So it's not just for errors, despite the name, but also warn and info states.
-The set_err method, and thus HandleSetErr, may be called multiple
+The set_err() method, and thus HandleSetErr, may be called multiple
times within a method and is usually invoked from deep within driver code.
In theory a driver can use the return value from HandleSetErr via
@@ -3056,7 +3080,7 @@
the 'error', the driver could then continue instead of failing (if
that's a reasonable thing to do). This isn't excepted to be
common and any such cases should be clearly marked in the driver
-documentation.
+documentation and discussed on the dbi-dev mailing list.
=item C<ShowErrorStatement> (boolean, inherited)
Modified: dbi/trunk/DBI.xs
==============================================================================
--- dbi/trunk/DBI.xs (original)
+++ dbi/trunk/DBI.xs Sat Feb 21 15:19:10 2004
@@ -494,10 +494,17 @@
err_changed = 1;
}
- if (SvTRUE(state) && err_changed) {
- if (SvCUR(state) != 5)
- croak("set_err: state must be 5 character string");
- sv_setsv(h_state, state);
+ if (err_changed) {
+ if (SvTRUE(state)) {
+ if (strlen(SvPV_nolen(state)) != 5) {
+ warn("set_err: state (%s) is not a 5 character string, using 'S1000'
instead", neatsvpv(state,0));
+ sv_setpv(h_state, "S1000");
+ }
+ else
+ sv_setsv(h_state, state);
+ }
+ else
+ (void)SvOK_off(h_state); /* see DBIc_STATE_adjust */
}
return 1;
@@ -625,7 +632,7 @@
(long)(level & ~DBIc_TRACE_LEVEL_MASK),
DBIc_TRACE_LEVEL(imp_xxh), DBIc_TRACE_FLAGS(imp_xxh),
XS_VERSION, dbi_build_opt, (int)PerlProc_getpid());
- if (!dowarn && level>0)
+ if (!PL_dowarn && level>0)
PerlIO_printf(DBIc_LOGPIO(imp_xxh)," Note: perl is running without
the recommended perl -w option\n");
PerlIO_flush(DBIc_LOGPIO(imp_xxh));
}
@@ -876,7 +883,9 @@
|DBIcf_ACTIVE /* drivers are 'Active' by default */
|DBIcf_AutoCommit /* advisory, driver must manage this */
);
- } else {
+ DBIc_set(imp, DBIcf_PrintWarn, PL_dowarn); /* set if warnings enabled */
+ }
+ else {
DBIc_PARENT_H(imp) = (SV*)SvREFCNT_inc(p_h); /* ensure it lives */
DBIc_PARENT_COM(imp) = p_imp_xxh; /* shortcut for speed */
DBIc_TYPE(imp) = DBIc_TYPE(p_imp_xxh) + 1;
@@ -1031,10 +1040,11 @@
if (DBIc_WARN(imp_xxh)) sv_catpv(flags,"Warn ");
if (DBIc_COMPAT(imp_xxh)) sv_catpv(flags,"CompatMode ");
if (DBIc_is(imp_xxh, DBIcf_ChopBlanks)) sv_catpv(flags,"ChopBlanks ");
- if (DBIc_is(imp_xxh, DBIcf_RaiseError)) sv_catpv(flags,"RaiseError ");
- if (DBIc_is(imp_xxh, DBIcf_PrintError)) sv_catpv(flags,"PrintError ");
if (DBIc_is(imp_xxh, DBIcf_HandleSetErr)) sv_catpv(flags,"HandleSetErr ");
if (DBIc_is(imp_xxh, DBIcf_HandleError)) sv_catpv(flags,"HandleError ");
+ if (DBIc_is(imp_xxh, DBIcf_RaiseError)) sv_catpv(flags,"RaiseError ");
+ if (DBIc_is(imp_xxh, DBIcf_PrintError)) sv_catpv(flags,"PrintError ");
+ if (DBIc_is(imp_xxh, DBIcf_PrintWarn)) sv_catpv(flags,"PrintWarn ");
if (DBIc_is(imp_xxh, DBIcf_ShowErrorStatement))
sv_catpv(flags,"ShowErrorStatement ");
if (DBIc_is(imp_xxh, DBIcf_AutoCommit)) sv_catpv(flags,"AutoCommit ");
if (DBIc_is(imp_xxh, DBIcf_BegunWork)) sv_catpv(flags,"BegunWork ");
@@ -1364,6 +1374,9 @@
else if (strEQ(key, "PrintError")) {
DBIc_set(imp_xxh,DBIcf_PrintError, on);
}
+ else if (strEQ(key, "PrintWarn")) {
+ DBIc_set(imp_xxh,DBIcf_PrintWarn, on);
+ }
else if (strEQ(key, "HandleError")) {
if ( on && (!SvROK(valuesv) || (SvTYPE(SvRV(valuesv)) != SVt_PVCV)) ) {
croak("Can't set HandleError to '%s'",neatsvpv(valuesv,0));
@@ -1713,6 +1726,9 @@
if (keylen==10 && strEQ(key, "PrintError")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintError));
}
+ else if (keylen==9 && strEQ(key, "PrintWarn")) {
+ valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_PrintWarn));
+ }
break;
case 'R':
@@ -2463,7 +2479,7 @@
if (trace_level >= 4 && 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" : SvCUR(err_sv) ? "warn" : "info",
+ SvTRUE(err_sv) ? "ERROR" : strlen(SvPV_nolen(err_sv)) ? "warn" :
"info",
neatsvpv(DBIc_ERR(imp_xxh),0), meth_name);
}
DBIh_CLEAR_ERROR(imp_xxh);
@@ -2618,7 +2634,7 @@
}
if (SvOK(err_sv)) {
PerlIO_printf(logfp, " %s %s %s %s\n", (keep_error) ? " " : "!!",
- SvTRUE(err_sv) ? "ERROR:" : SvCUR(err_sv) ? "warn:" : "info:",
+ SvTRUE(err_sv) ? "ERROR:" : strlen(SvPV_nolen(err_sv)) ? "warn:" :
"info:",
neatsvpv(err_sv,0), neatsvpv(DBIc_ERRSTR(imp_xxh),0));
}
PerlIO_printf(logfp,"%c%c <- %s",
@@ -2743,16 +2759,17 @@
if ( !keep_error /* is a new err/warn/info */
&& call_depth <= 1 /* skip nested (internal) calls */
&& (
- /* is an error and has RaiseError|PrintError|HandleError set */
+ /* is an error and has RaiseError|PrintError|HandleError set */
(SvTRUE(err_sv) && DBIc_has(imp_xxh,
DBIcf_RaiseError|DBIcf_PrintError|DBIcf_HandleError))
- /* is a warn (not info) and has PrintError set */
- || ( SvOK(err_sv) && SvCUR(err_sv) && DBIc_has(imp_xxh, DBIcf_PrintError))
+ /* is a warn (not info) and has PrintWarn set */
+ || ( SvOK(err_sv) && strlen(SvPV_nolen(err_sv)) && DBIc_has(imp_xxh,
DBIcf_PrintWarn))
)
/* check that we're not nested inside a call to our parent */
&& (!DBIc_PARENT_COM(imp_xxh) || DBIc_CALL_DEPTH(DBIc_PARENT_COM(imp_xxh)) < 1)
) {
SV *msg;
SV **statement_svp = NULL;
+ int is_warning = (!SvTRUE(err_sv) && strlen(SvPV_nolen(err_sv))==1);
char *err_meth_name = meth_name;
char intro[200];
@@ -2764,7 +2781,7 @@
/* XXX change to vsprintf into sv directly */
sprintf(intro,"%s %s %s: ", HvNAME(DBIc_IMP_STASH(imp_xxh)), err_meth_name,
- SvTRUE(err_sv) ? "failed" : SvCUR(err_sv) ? "warning" : "information");
+ SvTRUE(err_sv) ? "failed" : is_warning ? "warning" : "information");
msg = sv_2mortal(newSVpv(intro,0));
sv_catsv(msg, DBIc_ERRSTR(imp_xxh));
@@ -2857,10 +2874,14 @@
dbi_profile(h, imp_xxh, Statement, imp_msv ? imp_msv : (SV*)cv,
profile_t1, dbi_time());
}
- if (!hook_svp) {
+ if (is_warning) {
+ if (DBIc_has(imp_xxh, DBIcf_PrintWarn))
+ warn("%s", SvPV(msg,lna));
+ }
+ else if (!hook_svp && SvTRUE(err_sv)) {
if (DBIc_has(imp_xxh, DBIcf_PrintError))
warn("%s", SvPV(msg,lna));
- if (DBIc_has(imp_xxh, DBIcf_RaiseError) && SvTRUE(err_sv))
+ if (DBIc_has(imp_xxh, DBIcf_RaiseError))
croak("%s", SvPV(msg,lna));
}
}
@@ -3451,7 +3472,7 @@
if (level > 0) {
PerlIO_printf(DBILOGFP," DBI %s%s dispatch trace level set to %d (in
pid %d)\n",
XS_VERSION, dbi_build_opt, level, (int)PerlProc_getpid());
- if (!dowarn)
+ if (!PL_dowarn)
PerlIO_printf(DBILOGFP," Note: perl is running without the
recommended perl -w option\n");
PerlIO_flush(DBILOGFP);
}
Modified: dbi/trunk/DBIXS.h
==============================================================================
--- dbi/trunk/DBIXS.h (original)
+++ dbi/trunk/DBIXS.h Sat Feb 21 15:19:10 2004
@@ -248,6 +248,7 @@
#define DBIcf_TaintIn 0x020000 /* check inputs for taintedness */
#define DBIcf_TaintOut 0x040000 /* taint outgoing data */
#define DBIcf_Executed 0x080000 /* do/execute called since commit/rollb */
+#define DBIcf_PrintWarn 0x100000 /* warn() on warning (err="0") */
/* NOTE: new flags may require clone() to be updated */
#define DBIcf_INHERITMASK /* what NOT to pass on to children */ \
@@ -360,7 +361,7 @@
#define DBIh_CLEAR_ERROR(imp_xxh) (void)( \
(void)SvOK_off(DBIc_ERR(imp_xxh)), \
(void)SvOK_off(DBIc_ERRSTR(imp_xxh)), \
- (SvPOK(DBIc_STATE(imp_xxh)) ? SvCUR(DBIc_STATE(imp_xxh))=0 : 0) \
+ (void)SvOK_off(DBIc_STATE(imp_xxh)) \
)
Modified: dbi/trunk/Makefile.PL
==============================================================================
--- dbi/trunk/Makefile.PL (original)
+++ dbi/trunk/Makefile.PL Sat Feb 21 15:19:10 2004
@@ -49,7 +49,7 @@
$::opt_v = 0;
$::opt_thread = 1; # thread if we can, use "-nothread" to disable
$::opt_g = 0;
-$::opt_g = 1 if -d '.svn' && $ENV{LOGNAME} eq 'timbo'; # it's me! (probably)
+$::opt_g = 1 if -d '.svn' && $ENV{LOGNAME} && $ENV{LOGNAME} eq 'timbo'; # it's me!
(probably)
GetOptions(qw(v! g! thread!))
or die "Invalid arguments\n";
Modified: dbi/trunk/lib/DBI/PurePerl.pm
==============================================================================
--- dbi/trunk/lib/DBI/PurePerl.pm (original)
+++ dbi/trunk/lib/DBI/PurePerl.pm Sat Feb 21 15:19:10 2004
@@ -118,6 +118,7 @@
LongTruncOk
MultiThread
PrintError
+ PrintWarn
RaiseError
ShowErrorStatement
Warn
@@ -281,19 +282,22 @@
} if IMA_END_WORK & $bitmask;
push @post_call_frag, q{
- if ( !$keep_error && defined(my $err=$h->{err}) ) {
+ if ( !$keep_error
+ && defined(my $err = $h->{err})
+ && ($call_depth <= 1 && !$h->{_parent}{_call_depth})
+ ) {
- my $at_top = ($call_depth <= 1 && !$h->{_parent}{_call_depth});
- my($pe,$re,$he) = @{$h}{qw(PrintError RaiseError HandleError)};
+ my($pe,$pw,$re,$he) = @{$h}{qw(PrintError PrintWarn RaiseError
HandleError)};
my $msg;
- if ($err && $at_top && ($pe || $re || $he) # error at top level
- or (!$err && $pe) # warning/info
+ if ($err && ($pe || $re || $he) # error
+ or (!$err && length($err) && $pw) # warning
) {
my $last = ($DBI::last_method_except{$method_name})
? ($h->{'_last_method'}||$method_name) : $method_name;
my $errstr = $h->{errstr} || $DBI::errstr || $err || '';
- my $msg = sprintf "%s %s failed: %s", $imp, $last, $errstr;
+ my $msg = sprintf "%s %s %s: %s", $imp, $last,
+ ($err eq "0") ? "warning" : "failed", $errstr;
if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) {
$msg .= ' for [``' . $Statement . "''";
@@ -306,12 +310,10 @@
}
$msg .= "]";
}
- # have a 'warning' (not info) and PrintError is set
- if (defined $DBI::err and $DBI::err eq "0") {
- warn $msg if $pe;
+ if ($DBI::err eq "0") { # is 'warning' (not info)
+ carp $msg if $pw;
}
-
- if ($DBI::err) {
+ else {
my $do_croak = 1;
if (my $subsub = $h->{'HandleError'}) {
$do_croak = 0 if &$subsub($msg,$h,$ret[0]);
@@ -391,7 +393,7 @@
$h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained
if ($parent) {
foreach (qw(
- RaiseError PrintError HandleError HandleSetErr
+ RaiseError PrintError PrintWarn HandleError HandleSetErr
Warn LongTruncOk ChopBlanks AutoCommit
ShowErrorStatement FetchHashKeyName LongReadLen CompatMode
)) {
@@ -409,6 +411,7 @@
}
else { # setting up a driver handle
$h_inner->{Warn} = 1;
+ $h_inner->{PrintWarn} = $^W;
$h_inner->{AutoCommit} = 1;
$h_inner->{TraceLevel} = 0;
$h_inner->{CompatMode} = (1==0);
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Sat Feb 21 15:19:10 2004
@@ -123,7 +123,7 @@
ok($DBI::errstr, "foo 42 dbh [err was 42 now 99]\nfoo");
$drh->default_user("",""); # just to reset err etc
-$drh->set_err(0, "00000");
+$drh->set_err(1, "errmsg", "00000");
ok($DBI::state, "");
$drh->set_err(1, "test error 1");
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Sat Feb 21 15:19:10 2004
@@ -27,6 +27,7 @@
ok(!$dbh->{CompatMode} );
ok(!$dbh->{InactiveDestroy} );
ok(!$dbh->{PrintError} );
+ok( $dbh->{PrintWarn} ); # true because of perl -w above
ok( $dbh->{RaiseError} );
ok(!$dbh->{ShowErrorStatement} );
ok(!$dbh->{ChopBlanks} );
@@ -68,18 +69,13 @@
ok( UNIVERSAL::isa($drh, 'DBI::dr') );
ok( $dbh->err );
-# error in $drh same as $dbh because Err/Errstr/State are set at drh level
-#ok( $drh->err );
-#is( $drh->errstr, 'Unknown field names: foo' );
-#is( $drh->state, 'S1000' );
-ok(1); ok(1); ok(1);
-
ok( $drh->{Warn} );
ok( $drh->{Active} );
ok( $drh->{AutoCommit} );
ok(!$drh->{CompatMode} );
ok(!$drh->{InactiveDestroy} );
ok(!$drh->{PrintError} );
+ok( $drh->{PrintWarn} ); # true because of perl -w above
ok(!$drh->{RaiseError} );
ok(!$drh->{ShowErrorStatement} );
ok(!$drh->{ChopBlanks} );
@@ -127,6 +123,7 @@
ok(!$sth->{CompatMode} );
ok(!$sth->{InactiveDestroy} );
ok(!$sth->{PrintError} );
+ok( $sth->{PrintWarn} );
ok( $sth->{RaiseError} );
ok(!$sth->{ShowErrorStatement} );
ok(!$sth->{ChopBlanks} );
Modified: dbi/trunk/t/08keeperr.t
==============================================================================
--- dbi/trunk/t/08keeperr.t (original)
+++ dbi/trunk/t/08keeperr.t Sat Feb 21 15:19:10 2004
@@ -1,7 +1,7 @@
#!../perl -w
use strict;
-use Test::More tests => 62;
+use Test::More tests => 63;
$|=1;
$^W=1;
@@ -53,16 +53,19 @@
my $dbh = DBI->connect(@con_info);
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 1;
+$dbh->{PrintWarn} = 1;
-my $warn = 0;
+my %warn = ( failed => 0, warning => 0 );
my @handlewarn = (0,0,0);
$SIG{__WARN__} = sub {
- if ($_[0] =~ /^DBD::ExampleP::/) {
- ++$warn;
- print "warn called: @_\n";
+ my $msg = shift;
+ if ($msg =~ /^DBD::ExampleP::\S+\s+(\S+)\s+(\w+)/) {
+ ++$warn{$2};
+ $msg =~ s/\n/\\n/g;
+ print "warn: '$msg'\n";
return;
}
- warn @_;
+ warn $msg;
};
#$dbh->trace(2);
$dbh->{HandleSetErr} = sub {
@@ -85,54 +88,56 @@
is($DBI::err, "");
is($DBI::errstr, "(got info)");
is($dbh->errstr, "(got info)");
-is($warn, 0);
+is($warn{failed}, 0);
+is($warn{warning}, 0);
is("@handlewarn", "1 0 0");
-$dbh->set_err(0, "(got warn)", "AA001");
+$dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn
ok(defined $DBI::err);
is($DBI::err, "0");
is($DBI::errstr, "(got info)\n(got warn)");
is($dbh->errstr, "(got info)\n(got warn)");
-is($warn, 1);
+is($warn{warning}, 1);
is("@handlewarn", "1 1 0");
is($DBI::state, "AA001");
-$dbh->set_err("", "(got more info)");
+$dbh->set_err("", "(got more info)"); # triggers PrintWarn
ok(defined $DBI::err);
is($DBI::err, "0"); # not "", ie it's still a warn
is($dbh->err, "0");
is($DBI::errstr, "(got info)\n(got warn)\n(got more info)");
is($dbh->errstr, "(got info)\n(got warn)\n(got more info)");
-is($warn, 2);
+is($warn{warning}, 2);
is("@handlewarn", "2 1 0");
is($DBI::state, "AA001");
$dbh->{RaiseError} = 0;
-$dbh->{PrintError} = 0;
+$dbh->{PrintError} = 1;
$dbh->set_err("42", "(got error)", "AA002");
is($DBI::err, 42);
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)");
-is($warn, 2);
+#is($warn{failed}, 1);
+is($warn{warning}, 2);
is("@handlewarn", "2 1 1");
is($DBI::state, "AA002");
$dbh->set_err("", "(got info)");
is($DBI::err, 42);
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)");
-is($warn, 2);
+is($warn{warning}, 2);
is("@handlewarn", "3 1 1");
-$dbh->set_err("0", "(got warn)");
+$dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err
is($DBI::err, 42);
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn)");
-is($warn, 2);
+is($warn{warning}, 2);
is("@handlewarn", "3 2 1");
$dbh->set_err("4200", "(got new error)", "AA003");
is($DBI::err, 4200);
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now
AA003]\n(got new error)");
-is($warn, 2);
+is($warn{warning}, 2);
is("@handlewarn", "3 2 2");
$dbh->set_err(undef, "foo", "bar"); # clear error
@@ -140,20 +145,21 @@
ok(!defined $dbh->err);
is($dbh->state, "");
-$warn = 0;
+
+%warn = ( failed => 0, warning => 0 );
@handlewarn = (0,0,0);
my @ret;
[EMAIL PROTECTED] = $dbh->set_err(1, "foo");
[EMAIL PROTECTED] = $dbh->set_err(1, "foo"); # PrintError
is(scalar @ret, 1);
ok(!defined $ret[0]);
-ok(!defined $dbh->set_err(2, "bar"));
-ok(!defined $dbh->set_err(3, "baz"));
-ok(!defined $dbh->set_err(0, "warn"));
+ok(!defined $dbh->set_err(2, "bar")); # PrintError
+ok(!defined $dbh->set_err(3, "baz")); # PrintError
+ok(!defined $dbh->set_err(0, "warn")); # PrintError
is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn");
-is($warn, 0);
+is($warn{failed}, 4);
is("@handlewarn", "0 1 3");
-$dbh->set_err(undef, undef, undef); # clear error
+$dbh->set_err(undef, undef, undef); # clear error
@ret = $dbh->set_err(1, "foo", "AA123", "method");
is(scalar @ret, 1);
ok(!defined $ret[0]);
@@ -163,10 +169,12 @@
@ret = $dbh->set_err(1, "foo", "return");
is(scalar @ret, 0);
-$dbh->set_err(undef, undef, undef); # clear error
+$dbh->set_err(undef, undef, undef); # clear error
@ret = $dbh->set_err("", "info", "override");
is(scalar @ret, 1);
ok(!defined $ret[0]);
is($dbh->err, 99);
is($dbh->errstr, "errstr99");
is($dbh->state, "OV123");
+
+# end
