t/08keeperr.t - metacpan.org

#!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->{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->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->{examplep_set_err} = "0"; # set warning state
    cmp_ok($warn{warning}, '==', 1,      'warning generated for set_err("0") in STORE');
}

# ---

# ----
done_testing();

1;
# end
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)