File Coverage

blib/lib/Exception/Class/DBI.pm

Criterion	Covered	Total	%
statement	66	67	98.5
branch	11	16	68.7
condition	2	6	33.3
subroutine	35	35	100.0
pod	28	28	100.0
total	142	152	93.4

package Exception::Class::DBI;

use 5.006;
use strict;
use warnings;
use Exception::Class;

our $VERSION = '1.03_01';
$VERSION =~ tr/_//d;

use Exception::Class (
    'Exception::Class::DBI' => {
        description => 'DBI exception',
        fields      => [qw(err errstr state retval handle)]
    },

    'Exception::Class::DBI::Unknown' => {
        isa         => 'Exception::Class::DBI',
        description => 'DBI unknown exception'
    },

    'Exception::Class::DBI::H' => {
        isa         => 'Exception::Class::DBI',
        description => 'DBI handle exception',
    },

    'Exception::Class::DBI::DRH' => {
        isa         => 'Exception::Class::DBI::H',
        description => 'DBI driver handle exception',
    },

    'Exception::Class::DBI::DBH' => {
        isa         => 'Exception::Class::DBI::H',
        description => 'DBI database handle exception',
    },

    'Exception::Class::DBI::STH' => {
        isa         => 'Exception::Class::DBI::H',
        description => 'DBI statment handle exception',
    }
);

my %handlers;
sub handler {
    my $pkg = shift;
    return $handlers{$pkg} if $handlers{$pkg};

    # Support subclasses.
    my %class_for =  map {
        $_ => do {
            my $class = "$pkg\::$_";
            my $base  = __PACKAGE__ . "::$_";
            no strict 'refs';
            # Try to load the subclass and check its inheritance.
            eval "require $class" unless @{"$class\::ISA"};
            my $isa = \@{"$class\::ISA"};
            die "$class is not a subclass of $base"
                if $isa && !$class->isa($base);
            # If subclass exists and inherits, use it. Otherwise use default.
            $isa ? $class : $base;
        }
    } qw(H DRH DBH STH Unknown);

    return $handlers{$pkg} = sub {
        my ($err, $dbh, $retval) = @_;

        # No handle, no choice.
        $pkg->throw(
            error  => $err,
            retval => $retval
        ) unless ref($dbh ||= $DBI::lasth);

        # Assemble arguments for a handle exception.
        my @params = (
            error  => $err,
            errstr => $dbh->errstr,
            err    => $dbh->err,
            state  => $dbh->state,
            retval => $retval,
            handle => $dbh,
        );

        # Throw the proper exception.
        $class_for{STH}->throw(@params) if eval { $dbh->isa('DBI::st') };
        $class_for{DBH}->throw(@params) if eval { $dbh->isa('DBI::db') };
        $class_for{DRH}->throw(@params) if eval { $dbh->isa('DBI::dr') };

        # Unknown exception. This shouldn't happen.
        $class_for{Unknown}->throw(@params);
    };
}

package Exception::Class::DBI::H;
sub warn                { shift->handle->{Warn} }
sub active              { shift->handle->{Active} }
sub kids                { shift->handle->{Kids} }
sub active_kids         { shift->handle->{ActiveKids} }
sub compat_mode         { shift->handle->{CompatMode} }
sub inactive_destroy    { shift->handle->{InactiveDestroy} }
sub trace_level         { shift->handle->{TraceLevel} }
sub fetch_hash_key_name { shift->handle->{FetchHashKeyName} }
sub chop_blanks         { shift->handle->{ChopBlanks} }
sub long_read_len       { shift->handle->{LongReadLen} }
sub long_trunc_ok       { shift->handle->{LongTruncOk} }
sub taint               { shift->handle->{Taint} }

package Exception::Class::DBI::DBH;
sub auto_commit         { shift->handle->{AutoCommit} }
sub db_name             { shift->handle->{Name} }
sub statement           { shift->handle->{Statement} }
sub row_cache_size      { shift->handle->{RowCacheSize} }

package Exception::Class::DBI::STH;
sub num_of_fields       { shift->handle->{NUM_OF_FIELDS} }
sub num_of_params       { shift->handle->{NUM_OF_PARAMS} }
sub field_names         { shift->handle->{NAME} }
sub type                { shift->handle->{TYPE} }
sub precision           { shift->handle->{PRECISION} }
sub scale               { shift->handle->{SCALE} }
sub nullable            { shift->handle->{NULLABLE} }
sub cursor_name         { shift->handle->{CursorName} }
sub param_values        { shift->handle->{ParamValues} }
sub statement           { shift->handle->{Statement} }
sub rows_in_cache       { shift->handle->{RowsInCache} }

1;
__END__