File Coverage

blib/lib/Paranoid/BerkeleyDB.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	38	40	95.0

# Paranoid::BerkeleyDB -- BerkeleyDB Wrapper
#
# (c) 2005 - 2015, Arthur Corliss
#
# $Id: lib/Paranoid/BerkeleyDB.pm, 2.02 2016/06/21 19:51:06 acorliss Exp $
#
#    This software is licensed under the same terms as Perl, itself.
#    Please see http://dev.perl.org/licenses/ for more information.
#
#####################################################################

#####################################################################
#
# Dbironment definitions
#
#####################################################################

package Paranoid::BerkeleyDB;

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 Class::EHierarchy qw(:all);
use BerkeleyDB;
use Paranoid::BerkeleyDB::Env;
use Paranoid::BerkeleyDB::Db;
use Carp;

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

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

@ISA = qw(Class::EHierarchy);

@_properties = (
    [ CEH_RESTR | CEH_SCALAR, 'filename' ],
    [ CEH_RESTR | CEH_SCALAR, 'pid' ],
    [ CEH_RESTR | CEH_REF,    'cursor' ],
    [ CEH_PRIV | CEH_REF,     'dbh' ],
    );
@_methods = ( [ CEH_PUB, 'dbh' ], );

our $db46 = 0;

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

sub _initialize {

    # Purpose:  Create the database object and env object (if needed)
    # Returns:  Boolean
    # Usage:    $rv = $obj->_initialize(%params);

    my $obj    = shift;
    my %params = @_;
    my $rv     = 0;
    my ( $db, $env, $fn );

    # Make sure minimal parameters are preset
    pdebug( 'entering w/%s', PDLEVEL1, %params );
    pIn();

    # Set db46 flag
    $db46 = 1
        if DB_VERSION_MAJOR > 4
            or ( DB_VERSION_MAJOR == 4 and DB_VERSION_MINOR >= 6 );

    # Set up the environment
    if ( exists $params{Home} ) {
        $env = new Paranoid::BerkeleyDB::Env '-Home' => $params{Home};
    } elsif ( exists $params{Env}
        and defined $params{Env}
        and ref $params{Env} eq 'HASH' ) {
        $env = new Paranoid::BerkeleyDB::Env %{ $params{Env} };
    } elsif ( exists $params{Env}
        and defined $params{Env}
        and $params{Env}->isa('Paranoid::BerkeleyDB::Env') ) {
        $env = $params{Env};
    }

    Paranoid::ERROR =
        pdebug( 'failed to acquire a bdb environment', PDLEVEL1 )
        unless defined $env;

    # Set up the database
    if ( defined $env ) {
        if ( exists $params{Filename} ) {
            $fn = $params{Filename};
            $db = new Paranoid::BerkeleyDB::Db
                '-Filename' => $params{Filename},
                '-Env'      => $env;
        } elsif ( exists $params{Db}
            and defined $params{Db}
            and ref $params{Db} eq 'HASH' ) {
            $fn = $params{Db}{'-Filename'};
            $params{Db}{'-Env'} = $env;
            $db = new Paranoid::BerkeleyDB::Db %{ $params{Db} };
        }

        if ( defined $db ) {
            $obj->adopt($env);
            $obj->property( 'pid',      $$ );
            $obj->property( 'filename', $fn );
            $obj->property( 'dbh',      $db->db );
            $rv = 1;
        } else {
            Paranoid::ERROR =
                pdebug( 'failed to open the database', PDLEVEL1 );
        }
    }

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

    return $rv;
}

sub _deconstruct {

    # Purpose:  Object cleanup
    # Returns:  Boolean
    # Usage:    $rv = $obj->deconstruct;

    my $obj = shift;

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

    $obj->property( 'cursor', undef );
    $obj->property( 'dbh',    undef );

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

    return 1;
}

sub dbh {

    # Purpose:  Performs PID check before returning dbh
    # Returns:  Db ref
    # Usage:    $dbh = $obj->dbh;

    my $obj = shift;
    my $pid = $obj->property('pid');
    my $fn  = $obj->property('filename');
    my ( $rv, @children );

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

    if ( $$ == $pid ) {

        # Same process
        $rv = $obj->property('dbh');

    } else {

        # :-) Nothing to see here, can't seem to get it to
        # work like the old days...
        croak 'attempted to access an open database in a forked process';

        # Purge current references
        $obj->property( 'cursor', undef );
        $obj->property( 'dbh',    undef );

        # Get a list of children and find the same database
        @children = ( $obj->children )[0]->children;
        foreach (@children) {
            if ( $fn = $_->property('filename') ) {
                $obj->property( 'pid', $$ );
                $obj->property( 'dbh', $_->db );
                $rv = $_->db;
                last;
            }
        }
    }

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

    return $rv;
}

sub cds_lock {

    # Purpose:  Simple wrapper to get a CDS lock
    # Returns:  CDS Lock
    # Usage:    $lock = $dbh->cds_lock;

    my $obj = shift;
    my $dbh = $obj->dbh;

    return $dbh->cds_lock;
}

sub TIEHASH {
    my @args = @_;

    shift @args;

    return new Paranoid::BerkeleyDB @args;
}

sub FETCH {
    my $obj = shift;
    my $key = shift;
    my $dbh = $obj->dbh;
    my ( $val, $rv );

    pdebug( 'entering w/(%s)', PDLEVEL3, $key );
    pIn();

    if ( !$dbh->db_get( $key, $val ) ) {
        $rv = $val;
    }

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

    return $rv;
}

sub STORE {
    my $obj = shift;
    my $key = shift;
    my $val = shift;
    my $dbh = $obj->dbh;
    my $rv;

    pdebug( 'entering w/(%s)(%s)', PDLEVEL3, $key, $val );
    pIn();

    $rv = !$dbh->db_put( $key, $val );

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

    return $rv;
}

sub EXISTS {
    my $obj = shift;
    my $key = shift;
    my $dbh = $obj->dbh;
    my ( $val, $rv );

    pdebug( 'entering w/(%s)', PDLEVEL3, $key );
    pIn();

    $rv =
          $db46
        ? $dbh->db_exists($key) != DB_NOTFOUND
        : $dbh->db_get( $key, $val ) == 0;

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

    return $rv;
}

sub DELETE {
    my $obj = shift;
    my $key = shift;
    my $dbh = $obj->dbh;
    my $rv;

    pdebug( 'entering w/(%s)', PDLEVEL3, $key );
    pIn();

    $rv = !$dbh->db_del($key);

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

    return $rv;
}

sub CLEAR {
    my $obj = shift;
    my $dbh = $obj->dbh;
    my $rv  = 0;
    my $lock;

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

    $lock = $dbh->cds_lock if $dbh->cds_enabled;
    $dbh->truncate($rv);
    $lock->cds_unlock if defined $lock;

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

    return $rv;
}

sub FIRSTKEY {
    my $obj = shift;
    my $dbh = $obj->dbh;
    my ( $key, $val ) = ( '', '' );
    my ( $cursor, %o );

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

    $cursor = $dbh->db_cursor;

    if ( defined $cursor and $cursor->c_get( $key, $val, DB_NEXT ) == 0 ) {
        %o = ( $key => $val );
        $obj->property( 'cursor', $cursor );
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL3, %o );

    return each %o;
}

sub NEXTKEY {
    my $obj    = shift;
    my $cursor = $obj->property('cursor');
    my ( $key, $val ) = ( '', '' );
    my (%o);

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

    if ( defined $cursor ) {
        if ( $cursor->c_get( $key, $val, DB_NEXT ) == 0 ) {
            %o = ( $key => $val );
        } else {
            $obj->property( 'cursor', undef );
        }
    }

    pOut();
    pdebug( 'leaving w/rv: %s', PDLEVEL3, %o );

    return each %o;
}

sub SCALAR {
    my $obj = shift;
    my ( $key, $rv );

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

    if ( defined( $key = $obj->FIRSTKEY ) ) {
        $rv = 1;
        $obj->property( 'cursor', undef );
    } else {
        $rv = 0;
    }

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

    return $rv;
}

sub UNTIE {
    my $obj = shift;
    my $rv  = 1;

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

    $obj->property( 'cursor', undef );
    $obj->property( 'dbh',    undef );

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

    return $rv;
}

1;

__END__