353 lines
11 KiB
Perl
353 lines
11 KiB
Perl
#!perl -w
|
|
|
|
use strict;
|
|
|
|
use Test::More;
|
|
|
|
## ----------------------------------------------------------------------------
|
|
## 08keeperr.t
|
|
## ----------------------------------------------------------------------------
|
|
#
|
|
## ----------------------------------------------------------------------------
|
|
|
|
BEGIN {
|
|
use_ok('DBI');
|
|
}
|
|
|
|
$|=1;
|
|
$^W=1;
|
|
|
|
## ----------------------------------------------------------------------------
|
|
# subclass DBI
|
|
|
|
# DBI subclass
|
|
package My::DBI;
|
|
use base 'DBI';
|
|
|
|
# Database handle subclass
|
|
package My::DBI::db;
|
|
use base 'DBI::db';
|
|
|
|
# Statement handle subclass
|
|
package My::DBI::st;
|
|
use base 'DBI::st';
|
|
|
|
sub execute {
|
|
my $sth = shift;
|
|
# we localize an attribute here to check that the corresponding STORE
|
|
# at scope exit doesn't clear any recorded error
|
|
local $sth->{Warn} = 0;
|
|
my $rv = $sth->SUPER::execute(@_);
|
|
return $rv;
|
|
}
|
|
|
|
|
|
## ----------------------------------------------------------------------------
|
|
# subclass the subclass of DBI
|
|
|
|
package Test;
|
|
|
|
use strict;
|
|
use base 'My::DBI';
|
|
|
|
use DBI;
|
|
|
|
my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 1 });
|
|
|
|
sub test_select {
|
|
my $dbh = shift;
|
|
eval { $dbh->selectrow_arrayref('select * from foo') };
|
|
$dbh->disconnect;
|
|
return $@;
|
|
}
|
|
|
|
my $err1 = test_select( My::DBI->connect(@con_info) );
|
|
Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error');
|
|
|
|
my $err2 = test_select( DBI->connect(@con_info) );
|
|
Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex|Gofer)::db selectrow_arrayref failed: opendir/, '... checking error');
|
|
|
|
package main;
|
|
|
|
my $using_dbd_gofer = ( $ENV{DBI_AUTOPROXY} || '' ) =~ /^dbi:Gofer.*transport=/i;
|
|
|
|
|
|
# test ping does not destroy the errstr
|
|
sub ping_keeps_err {
|
|
my $dbh = DBI->connect('DBI:ExampleP:', undef, undef, { PrintError => 0 });
|
|
|
|
$dbh->set_err(42, "ERROR 42");
|
|
is $dbh->err, 42;
|
|
is $dbh->errstr, "ERROR 42";
|
|
ok $dbh->ping, "ping returns true";
|
|
is $dbh->err, 42, "err unchanged after ping";
|
|
is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
|
|
|
|
$dbh->disconnect;
|
|
|
|
$dbh->set_err(42, "ERROR 42");
|
|
is $dbh->err, 42, "err unchanged after ping";
|
|
is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
|
|
ok !$dbh->ping, "ping returns false";
|
|
# it's reasonable for ping() to set err/errstr if it fails
|
|
# so here we just test that there is an error
|
|
ok $dbh->err, "err true after failed ping";
|
|
ok $dbh->errstr, "errstr true after failed ping";
|
|
|
|
|
|
# for a driver which doesn't have its own ping
|
|
$dbh = DBI->connect('DBI:Sponge:', undef, undef, { PrintError => 0 });
|
|
$dbh->STORE(Active => 1);
|
|
|
|
$dbh->set_err(42, "ERROR 42");
|
|
is $dbh->err, 42;
|
|
is $dbh->errstr, "ERROR 42";
|
|
ok $dbh->ping, "ping returns true: ".$dbh->ping;
|
|
is $dbh->err, 42, "err unchanged after ping";
|
|
is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
|
|
|
|
$dbh->disconnect;
|
|
$dbh->STORE(Active => 0);
|
|
|
|
$dbh->set_err(42, "ERROR 42");
|
|
is $dbh->err, 42, "err unchanged after ping";
|
|
is $dbh->errstr, "ERROR 42", "errstr unchanged after ping";
|
|
ok !$dbh->ping, "ping returns false";
|
|
# it's reasonable for ping() to set err/errstr if it fails
|
|
# so here we just test that there is an error
|
|
ok $dbh->err, "err true after failed ping";
|
|
ok $dbh->errstr, "errstr true after failed ping";
|
|
|
|
}
|
|
|
|
## ----------------------------------------------------------------------------
|
|
print "Test HandleSetErr\n";
|
|
|
|
my $dbh = DBI->connect(@con_info);
|
|
isa_ok($dbh, "DBI::db");
|
|
|
|
$dbh->{RaiseError} = 1;
|
|
$dbh->{PrintError} = 1;
|
|
$dbh->{RaiseWarn} = 0;
|
|
$dbh->{PrintWarn} = 1;
|
|
|
|
# warning handler
|
|
my %warn;
|
|
my @handlewarn;
|
|
|
|
sub reset_warn_counts {
|
|
%warn = ( failed => 0, warning => 0 );
|
|
@handlewarn = (0,0,0);
|
|
}
|
|
reset_warn_counts();
|
|
|
|
$SIG{__WARN__} = sub {
|
|
my $msg = shift;
|
|
if ($msg =~ /^DBD::\w+::\S+\s+(\S+)\s+(\w+)/) {
|
|
++$warn{$2};
|
|
$msg =~ s/\n/\\n/g;
|
|
print "warn: '$msg'\n";
|
|
return;
|
|
}
|
|
warn $msg;
|
|
};
|
|
|
|
# HandleSetErr handler
|
|
$dbh->{HandleSetErr} = sub {
|
|
my ($h, $err, $errstr, $state) = @_;
|
|
return 0
|
|
unless defined $err;
|
|
++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls
|
|
return 1
|
|
if $state && $state eq "return"; # for tests
|
|
($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123")
|
|
if $state && $state eq "override"; # for tests
|
|
return 0
|
|
if $err; # be transparent for errors
|
|
local $^W;
|
|
print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n";
|
|
return 0;
|
|
};
|
|
|
|
# start our tests
|
|
|
|
ok(!defined $DBI::err, '... $DBI::err is not defined');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("", "(got info)");
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined'); # true
|
|
is($DBI::err, "", '... $DBI::err is an empty string');
|
|
is($DBI::errstr, "(got info)", '... $DBI::errstr is as we expected');
|
|
is($dbh->errstr, "(got info)", '... $dbh->errstr matches $DBI::errstr');
|
|
cmp_ok($warn{failed}, '==', 0, '... $warn{failed} is 0');
|
|
cmp_ok($warn{warning}, '==', 0, '... $warn{warning} is 0');
|
|
is_deeply(\@handlewarn, [ 1, 0, 0 ], '... the @handlewarn array is (1, 0, 0)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
is($DBI::err, "0", '... $DBI::err is "0"');
|
|
is($DBI::errstr, "(got info)\n(got warn)",
|
|
'... $DBI::errstr is as we expected');
|
|
is($dbh->errstr, "(got info)\n(got warn)",
|
|
'... $dbh->errstr matches $DBI::errstr');
|
|
is($DBI::state, "AA001", '... $DBI::state is AA001');
|
|
cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1');
|
|
is_deeply(\@handlewarn, [ 1, 1, 0 ], '... the @handlewarn array is (1, 1, 0)');
|
|
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("", "(got more info)"); # triggers PrintWarn
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's still a warn
|
|
is($dbh->err, "0", '... $dbh->err is "0"');
|
|
is($DBI::state, "AA001", '... $DBI::state is AA001');
|
|
is($DBI::errstr, "(got info)\n(got warn)\n(got more info)",
|
|
'... $DBI::errstr is as we expected');
|
|
is($dbh->errstr, "(got info)\n(got warn)\n(got more info)",
|
|
'... $dbh->errstr matches $DBI::errstr');
|
|
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
|
|
is_deeply(\@handlewarn, [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)');
|
|
|
|
# ----
|
|
|
|
$dbh->{RaiseError} = 0;
|
|
$dbh->{PrintError} = 1;
|
|
$dbh->{RaiseWarn} = 1;
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("42", "(got error)", "AA002");
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
|
|
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
|
|
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)",
|
|
'... $dbh->errstr is as we expected');
|
|
is($DBI::state, "AA002", '... $DBI::state is AA002');
|
|
is_deeply(\@handlewarn, [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("", "(got info)");
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
|
|
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
|
|
is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now AA002]\n(got error)\n(got info)",
|
|
'... $dbh->errstr is as we expected');
|
|
is_deeply(\@handlewarn, [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
|
|
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
|
|
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)",
|
|
'... $dbh->errstr is as we expected');
|
|
is_deeply(\@handlewarn, [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err("4200", "(got new error)", "AA003");
|
|
|
|
ok(defined $DBI::err, '... $DBI::err is defined');
|
|
cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200');
|
|
cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
|
|
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)",
|
|
'... $dbh->errstr is as we expected');
|
|
is_deeply(\@handlewarn, [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err(undef, "foo", "bar"); # clear error
|
|
|
|
ok(!defined $dbh->errstr, '... $dbh->errstr is defined');
|
|
ok(!defined $dbh->err, '... $dbh->err is defined');
|
|
is($dbh->state, "", '... $dbh->state is an empty string');
|
|
|
|
# ----
|
|
|
|
reset_warn_counts();
|
|
|
|
# ----
|
|
|
|
my @ret;
|
|
@ret = $dbh->set_err(1, "foo"); # PrintError
|
|
|
|
cmp_ok(scalar(@ret), '==', 1, '... only returned one value');
|
|
ok(!defined $ret[0], '... the first value is undefined');
|
|
ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); # PrintError
|
|
ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); # PrintError
|
|
ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); # PrintError
|
|
is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn",
|
|
'... $dbh->errstr is as we expected');
|
|
is($warn{failed}, 4, '... $warn{failed} is 4');
|
|
is_deeply(\@handlewarn, [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err(undef, undef, undef); # clear error
|
|
|
|
@ret = $dbh->set_err(1, "foo", "AA123", "method");
|
|
cmp_ok(scalar @ret, '==', 1, '... only returned one value');
|
|
ok(!defined $ret[0], '... the first value is undefined');
|
|
|
|
@ret = $dbh->set_err(1, "foo", "AA123", "method", "42");
|
|
cmp_ok(scalar @ret, '==', 1, '... only returned one value');
|
|
is($ret[0], "42", '... the first value is "42"');
|
|
|
|
@ret = $dbh->set_err(1, "foo", "return");
|
|
cmp_ok(scalar @ret, '==', 0, '... returned no values');
|
|
|
|
# ----
|
|
|
|
$dbh->set_err(undef, undef, undef); # clear error
|
|
|
|
@ret = $dbh->set_err("", "info", "override");
|
|
cmp_ok(scalar @ret, '==', 1, '... only returned one value');
|
|
ok(!defined $ret[0], '... the first value is undefined');
|
|
cmp_ok($dbh->err, '==', 99, '... $dbh->err is 99');
|
|
is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected');
|
|
is($dbh->state, "OV123", '... $dbh->state is as we expected');
|
|
$dbh->disconnect;
|
|
|
|
# ---
|
|
|
|
ping_keeps_err();
|
|
|
|
# ---
|
|
|
|
reset_warn_counts();
|
|
|
|
SKIP: {
|
|
# we could test this with gofer is we used a different keep_err method other than STORE
|
|
# to trigger the set_err calls
|
|
skip 'set_err keep_error skipped for Gofer', 2
|
|
if $using_dbd_gofer;
|
|
|
|
$dbh->{examplep_set_err} = ""; # set information state
|
|
cmp_ok($warn{warning}, '==', 0, 'no extra warning generated for set_err("") in STORE');
|
|
|
|
$dbh->{RaiseWarn} = 0;
|
|
|
|
$dbh->{examplep_set_err} = "0"; # set warning state
|
|
cmp_ok($warn{warning}, '==', 1, 'warning generated for set_err("0") in STORE');
|
|
}
|
|
|
|
# ---
|
|
|
|
# ----
|
|
done_testing();
|
|
|
|
1;
|
|
# end
|