File Coverage

lib/Object/Wrapper/Fork/DBI.pm

Criterion	Covered	Total	%
statement	36	69	52.1
branch	0	22	0.0
condition			n/a
subroutine	12	18	66.6
pod			n/a
total	48	109	44.0

########################################################################
# housekeeping
########################################################################

package Object::Wrapper::Fork::DBI;

use 5.8.0;
use strict;
use parent  qw( Object::Wrapper::Fork );

use Carp;

eval { require DBI };

use if ! $DBI::VERSION, 'Object::Wrapper::Fork::DBI_stubs';

########################################################################
# package variables & sanity checks
########################################################################

our $VERSION    = 0.03;

########################################################################
# utility subs
########################################################################

########################################################################
# public interface
########################################################################

sub connect
{
    # discard the object/class: this is a factory.

    shift;

    my $dbh     = DBI->connect( @_ )
    or croak 'Fail connect: ' . $DBI::errstr;

    Object::Wrapper::Fork::dbh->new( $dbh )
}

sub connect_cached
{
    shift;

    my $dbh     = DBI->connect_cached( @_ )
    or croak 'Fail connect_cached: ' . $DBI::errstr;

    Object::Wrapper::Fork::dbh->new( $dbh )
}

########################################################################
# handlers for database and statement handles
#
# both inherit AUTOLOAD from Fork (i.e., they check the pid).
########################################################################

package Object::Wrapper::Fork::dbh;

use 5.8.0;
use strict;
use parent  qw( Object::Wrapper::Fork );

use Carp    qw( croak confess );

sub prepare
{
    my $franger = shift;

    my ( $dbh, $pid ) = @$franger;

    $pid == $$
    or confess "Bogus prepare: @{ $franger } crosses fork.";

    my $sth = $dbh->prepare( @_ )
    or croak 'Failed prepare: ' . $dbh->errstr;

    Object::Wrapper::Fork::sth->new( $sth )
}

sub prepare_cached
{
    my $franger = shift;

    my ( $dbh, $pid ) = @$franger;

    $pid == $$
    or confess "Bogus prepare_cached: @{ $franger } crosses fork.";

    my $sth = $dbh->prepare_cached( @_ )
    or croak 'Failed prepare_cached: ' . $dbh->errstr;

    Object::Wrapper::Fork::sth->new( $sth )
}

sub cleanup
{
    my ( $dbh, $pid ) = @_;

    my $struct
    = do
    {
        my $drh     = $dbh->{ Driver };

        $drh
        ? $drh->{ CachedKids }
        : ''
    };

    my @kidz
    = $struct
    ? values %$struct
    : ()
    ;

    if( $$ != $pid )
    {
        # handle crossed a fork: turn off side
        # effects of destruction.

        $_->{ InactiveDestroy } = 1
        for
        (
            $dbh,
            @kidz
        );
    }
    else
    {
        $_->finish for @kidz;

        $dbh->disconnect;
    }

    # at this point the DBI object has been
    # prepared to go out of scope politely.

    return
}

########################################################################
# cleanup handler for statement handles

package Object::Wrapper::Fork::sth;

use 5.8.0;
use strict;
use parent qw( Object::Wrapper::Fork );

sub cleanup
{
    my ( $sth, $pid ) = @_;

    if( $$ ~~ $pid )
    {
        # same process: finalize the handle and disconnect.
        # caller deals with clones.

        $sth->{ Active }
        and $sth->finish;
    }
    else
    {
        $sth->{ InactiveDestroy } = 1;
    }

    # at this point the DBI object has been
    # prepared to go out of scope politely.

    return
}


# keep require happy

1

__END__