summaryrefslogtreecommitdiff
path: root/t/08keeperr.t
diff options
context:
space:
mode:
Diffstat (limited to 't/08keeperr.t')
-rw-r--r--t/08keeperr.t291
1 files changed, 291 insertions, 0 deletions
diff --git a/t/08keeperr.t b/t/08keeperr.t
new file mode 100644
index 0000000..617a81d
--- /dev/null
+++ b/t/08keeperr.t
@@ -0,0 +1,291 @@
+#!perl -w
+
+use strict;
+
+use Test::More tests => 79;
+
+## ----------------------------------------------------------------------------
+## 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 correpoding 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;
+
+# 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";
+}
+
+## ----------------------------------------------------------------------------
+print "Test HandleSetErr\n";
+
+my $dbh = DBI->connect(@con_info);
+isa_ok($dbh, "DBI::db");
+
+$dbh->{RaiseError} = 1;
+$dbh->{PrintError} = 1;
+$dbh->{PrintWarn} = 1;
+
+# warning handler
+my %warn = ( failed => 0, warning => 0 );
+my @handlewarn = (0,0,0);
+$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->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');
+
+# ----
+
+%warn = ( failed => 0, warning => 0 );
+@handlewarn = (0,0,0);
+
+# ----
+
+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();
+
+1;
+# end
View Lorry Controller Status