view release on metacpan or  search on metacpan

t/08keeperr.t  view on Meta::CPAN

    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");