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.03 2017/02/06 02:49:24 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;
use Cwd;

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

use vars qw(@ISA @_properties);

@ISA = qw(Class::EHierarchy);

@_properties = ( [ CEH_RESTR | CEH_REF, 'cursor' ], );

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, $fpath );

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

    # Get the filename's path, in case Home is not set
    ($fpath) = (
          exists $params{Filename} ? ( $params{Filename} =~ m#^(.*)/#s )
        : exists $params{Db} ? ( $params{Db}{'-Filename'} =~ m#^(.*)/#s )
        : getcwd() );

    # Set up the environment
    if (    exists $params{Env}
        and defined $params{Env}
        and ref $params{Env} eq 'HASH' ) {
        $params{Env}{'-Home'} = $fpath
            if !exists $params{Env}{Home}
                and defined $fpath
                and length $fpath;
        $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};
    } else {
        $params{Home} = $fpath unless exists $params{Home};
        $env = new Paranoid::BerkeleyDB::Env '-Home' => $params{Home};
    }

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

    # Set up the database
    if ( defined $env ) {
        if ( exists $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' ) {
            $params{Db}{'-Env'} = $env;
            $db = new Paranoid::BerkeleyDB::Db %{ $params{Db} };
        }

        if ( defined $db ) {
            $obj->adopt($env);
            $env->alias('env');
            $db->alias('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->set( 'cursor', undef ) if !$obj->isStale;

    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 ( $rv, @children );

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

    if ( !$obj->isStale ) {
        $rv = $obj->getByAlias('db')->dbh;
    } else {
        pdebug( 'dbh method called on stale object', PDLEVEL1 );
    }

    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;

    $dbh = $obj->dbh if !$obj->isStale;

    return defined $dbh ? $dbh->cds_lock : undef;
}

sub TIEHASH {
    my @args = @_;

    shift @args;

    return new Paranoid::BerkeleyDB @args;
}

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

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

    if ( !$obj->isStale ) {
        $dbh = $obj->dbh;
        if ( !$dbh->db_get( $key, $val ) ) {
            $rv = $val;
        }
    } else {
        $@ = pdebug( 'FETCH called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

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

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

    if ( !$obj->isStale ) {
        $rv = !$obj->dbh->db_put( $key, $val );
    } else {
        $@ = pdebug( 'STORE called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

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

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

    if ( !$obj->isStale ) {
        $dbh = $obj->dbh;
        $rv =
              $db46
            ? $dbh->db_exists($key) != DB_NOTFOUND
            : $dbh->db_get( $key, $val ) == 0;
    } else {
        $@ = pdebug( 'EXISTS called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

sub DELETE {
    my $obj = shift;
    my $key = shift;
    my $rv;

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

    if ( !$obj->isStale ) {
        $rv = !$obj->dbh->db_del($key);
    } else {
        $@ = pdebug( 'DELETE called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

sub CLEAR {
    my $obj = shift;
    my $rv  = 0;
    my ( $dbh, $lock );

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

    if ( !$obj->isStale ) {
        $dbh = $obj->dbh;
        $lock = $dbh->cds_lock if $dbh->cds_enabled;
        $dbh->truncate($rv);
        $lock->cds_unlock if defined $lock;
    } else {
        $@ = pdebug( 'CLEAR called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

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

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

    if ( !$obj->isStale ) {
        $cursor = $obj->dbh->db_cursor;

        if ( defined $cursor and $cursor->c_get( $key, $val, DB_NEXT ) == 0 )
        {
            %o = ( $key => $val );
            $obj->set( 'cursor', $cursor );
        }
    } else {
        $@ = pdebug( 'FIRSTKEY called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return each %o;
}

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

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

    if ( !$obj->isStale ) {
        if ( defined $cursor ) {
            if ( $cursor->c_get( $key, $val, DB_NEXT ) == 0 ) {
                %o = ( $key => $val );
            } else {
                $obj->set( 'cursor', undef );
            }
        }
    } else {
        $@ = pdebug( 'NEXTKEY called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return each %o;
}

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

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

    if ( !$obj->isStale ) {
        if ( defined( $key = $obj->FIRSTKEY ) ) {
            $rv = 1;
            $obj->set( 'cursor', undef );
        } else {
            $rv = 0;
        }
    } else {
        $@ = pdebug( 'SCALAR called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

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

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

    if ( !$obj->isStale ) {
        $obj->set( 'cursor', undef );
    } else {
        $@ = pdebug( 'UNTIE called on a stale object', PDLEVEL1 );
        carp $@;
    }

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

    return $rv;
}

1;

__END__