File Coverage

blib/lib/Paranoid/BerkeleyDB/Env.pm

Criterion	Covered	Total	%
statement	25	27	92.5
branch			n/a
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	34	36	94.4

# Paranoid::BerkeleyDB::Env -- BerkeleyDB CDS Env
#
# (c) 2005 - 2015, Arthur Corliss
#
# $Id: lib/Paranoid/BerkeleyDB/Env.pm, 2.01 2016/06/17 11:24:54 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::BerkeleyDB::Env;

use strict;
use warnings;
use vars qw($VERSION);
use Fcntl qw(:DEFAULT :flock :mode :seek);
use Paranoid;
use Paranoid::Debug qw(:all);
use Paranoid::IO;
use Paranoid::IO::Lockfile;
use Paranoid::BerkeleyDB::Core;
use Class::EHierarchy qw(:all);
use BerkeleyDB;

($VERSION) = ( q$Revision: 2.01 $ =~ /(\d+(?:\.\d+)+)/sm );

use vars qw(@ISA @_properties @_methods);

@_properties =
    ( [ CEH_PUB | CEH_SCALAR, 'home' ], [ CEH_PUB | CEH_HASH, 'params' ], );
@_methods = ( [ CEH_PUB, 'env' ], [ CEH_PUB, 'dbs' ], );

@ISA = qw(Class::EHierarchy);

#####################################################################
#
# module code follows
#
#####################################################################

{

    my %dbe;    # Object handles
    my %dbp;    # Parameters used for handles
    my %dbc;    # Reference count
    my %pid;    # Object handle create PID

    sub _openDbe {

        # Purpose:  Fork/redundant-open safe
        # Returns:  Reference to BerkeleyDB::Env object
        # Usage:    $env = _openDbe(%params);

        my %params = @_;
        my ( $env, $fh );

        pdebug( 'entering w/%s', PDLEVEL2, %params );
        pIn();

        if ( exists $dbe{ $params{'-Home'} } ) {
            pdebug( 'environment already exists', PDLEVEL3 );

            if ( $pid{ $params{'-Home'} } == $$ ) {
                pdebug( 'using cached reference', PDLEVEL3 );

                # Increment reference count
                $dbc{ $params{'-Home'} }++;
                $env = $dbe{ $params{'-Home'} };

            } else {

                pdebug( 'cached ref created under different pid', PDLEVEL3 );

                # Reuse prior parameters
                %params = %{ $dbp{ $params{'-Home'} } };

                # Install DESTROY filters
                _installScreener();
                _addBlacklist( $dbe{ $params{'-Home'} } );

                # Close everything
                delete $dbe{ $params{'-Home'} };
                delete $dbp{ $params{'-Home'} };
                delete $dbc{ $params{'-Home'} };
                delete $pid{ $params{'-Home'} };

                $env = _openDbe(%params);

            }

        } else {

            pdebug( 'creating a new environment', PDLEVEL3 );

            # Create an error log
            $params{'-ErrFile'} = "$params{'-Home'}/db_err.log"
                unless exists $params{'-ErrFile'};
            $fh = popen( $params{'-ErrFile'}, O_WRONLY | O_CREAT | O_APPEND );
            $params{'-ErrFile'} = $fh if defined $fh;

            # Add default flags if they're omitted
            $params{'-Mode'}  = 0666 & ~umask;
            $params{'-Flags'} = DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL
                unless exists $params{'-Flags'};
            $params{'-Verbose'} = 1;
            pdebug( 'final parameters: %s', PDLEVEL4, %params );

            # Create the environment
            if ( pexclock( "$params{'-Home'}/env.lock", $params{'-Mode'} ) ) {
                $env = BerkeleyDB::Env->new(%params);
                punlock("$params{'-Home'}/env.lock");
            }

            if ( defined $env ) {
                $dbe{ $params{'-Home'} } = $env;
                $dbp{ $params{'-Home'} } = {%params};
                $dbc{ $params{'-Home'} } = 1;
                $pid{ $params{'-Home'} } = $$;
            } else {
                Paranoid::ERROR = pdebug( 'failed to open environment: %s',
                    PDLEVEL1, $BerkeleyDB::Error );
            }
        }

        pOut();
        pdebug( 'leaving w/rv: %s', PDLEVEL2, $env );

        return $env;
    }

    sub _closeDbe {

        # Purpose:  Close env or decrements counter
        # Returns:  Boolean
        # Usage:    $rv = _closeDbe(%params);

        my %params = @_;

        pdebug( 'entering w/%s', PDLEVEL2, %params );
        pIn();

        if ( exists $dbe{ $params{'-Home'} } ) {
            if ( $dbc{ $params{'-Home'} } == 1 ) {
                pdebug( 'closing out environment', PDLEVEL4 );
                delete $dbe{ $params{'-Home'} };
                delete $dbp{ $params{'-Home'} };
                delete $dbc{ $params{'-Home'} };
                delete $pid{ $params{'-Home'} };
            } else {
                pdebug( 'decrementing ref count', PDLEVEL4 );
                $dbc{ $params{'-Home'} }--;
            }
        }

        pOut();
        pdebug( 'leaving w/rv: 1', PDLEVEL2 );

        return 1;
    }

    sub env {

        # Purpose:  Returns a handle
        # Returns:  Ref
        # Usage:    $env = $obj->env;

        my $obj  = shift;
        my $home = $obj->property('home');
        my $rv;

        pdebug( 'entering', PDLEVEL1 );
        pIn();

        $rv = $$ == $pid{$home}
            ? $rv = $dbe{$home}
            : _openDbe( $obj->property('params') );

        pOut();
        pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

        return $rv;
    }
}

sub _initialize {
    my $obj    = shift;
    my %params = @_;
    my $rv;

    # Make sure minimal parameters are preset
    pdebug( 'entering', PDLEVEL1 );
    pIn();

    if ( exists $params{'-Home'} ) {

        if ( defined _openDbe(%params) ) {
            $obj->property( 'home',   $params{'-Home'} );
            $obj->property( 'params', %params );
            $rv = 1;
        }

    } else {
        Paranoid::ERROR = pdebug( 'caller didn\'t specify -Home', PDLEVEL1 );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub _deconstruct {
    my $obj    = shift;
    my %params = $obj->property('params');
    my ( $rv, $db );

    pdebug( 'entering', PDLEVEL1 );
    pIn();

    foreach ( $obj->children ) {
        $obj->disown($_);
        $_ = undef;
    }
    $rv = _closeDbe(%params);

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL1, $rv );

    return $rv;
}

sub dbs {

    # Purpose:  Returns a list of database objects using this env
    # Returns:  List of objects
    # Usage:    @dbs = $dbe->dbs;

    my $obj = shift;

    return
        grep { defined $_ and $_->isa('Paranoid::BerkeleyDB::Db') }
        $obj->children;
}

1;

__END__