# Paranoid::BerkeleyDB -- BerkeleyDB Wrapper
#
# (c) 2005 - 2015, Arthur Corliss <corliss@digitalmages.com>
#
# $Id: lib/Paranoid/BerkeleyDB.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.
#
#####################################################################

#####################################################################
#
# 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.01 $ =~ /(\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' ], );

#####################################################################
#
# 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 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 $rv;

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

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

    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__

=head1 NAME

Paranoid::BerkeleyDB -- BerkeleyDB Wrapper

=head1 VERSION

$Id: lib/Paranoid/BerkeleyDB.pm, 2.01 2016/06/17 11:24:54 acorliss Exp $

=head1 SYNOPSIS

  tie %db, Paranoid::BerkeleyDB, 
    Home     => './dbdir',
    Filename => 'data.db';

  # Normal hash activities...

  # Ensure atomic updates
  $dref = tied %db;
  $lock = $dref->cds_lock;
  $db{$key}++;
  $lock->cds_unlock;

  untie %db;

=head1 DESCRIPTION

This module provides an OO/tie-based wrapper for BerkeleyDB CDS
implementations intended for use in tied hashes.

B<NOTE:> This module breaks significantly with previous incarnations of this
module.  The primary differences are as follows:

    Pros
    -------------------------------------------------------------
    * Places no limitations on the developer regarding BerekelyDB
      environment and database options
    * Automatically reuses existing environments for multiple 
      tied hashses
    * Uses Btree databases in lieu of hashes, which tended to 
      have issues when the database size grew too large
    * Has a fully implemented tied hash interface incorporating 
      CDS locks
    * Has pervasive debugging built in using L<Paranoid::Debug>

    Cons
    -------------------------------------------------------------
    * Is no longer considered fork-safe, attempted accesses will
      case the child process to B<croak>.
    * Uses Btree databases in lieu of hashes, which does add 
      some additional memory overhead

=head1 SUBROUTINES/METHODS

=head2 new

  tie %db, Paranoid::BerkeleyDB, 
    Home     => './dbdir',
    Filename => 'data.db';

This method is called implicitly when an object is tied.  It supports a few
differnet invocation styles.  The simplest involves simply providing the
B<Home> and B<Filename> options.  This will set up a CDS environment using the
defaults documented in L<Paranoid::BerkeleyDB::Env(3)> and
L<Paranoid::BerkeleyDB::Db(3)>.

Alternately, you can provide it with B<Filename> and a
L<Paranoid::BerkeleyDB::Env(3)> object (or subclassed object) that you
instantiated yourself:

  tie %db, Paranoid::BerkeleyDB, 
    Env      => $env,
    Filename => 'data.db';

Finally, you can provide it with two hash options to fully control the
environment and database instantiation of L<Paranoid::BerkeleyDB::Env(3)> and
L<Paranoid::BerkeleyDB::Db(3)>:

  tie %db, Paranoid::BerkeleyDB, 
    Env      => { %envOpts },
    Db       => { %dbOpts };

=head2 dbh

    $dref = tied %db;
    $dbh  = $dref->dbh;

This method provides access to the L<BerkeleyDB::Btree(3)> object reference.

=head2 cds_lock

    $dref = tied %db;
    $lock = $dref->cds_lock;

This methd provides access to the CDS locks for atomic updates.

=head1 DEPENDENCIES

=over

=item o

L<BerkeleyDB>

=item o

L<Carp>

=item o

L<Class::EHierarchy>

=item o

L<Fcntl>

=item o

L<Paranoid>

=item o

L<Paranoid::BerkeleyDB::Db>

=item o

L<Paranoid::BerkeleyDB::Env>

=item o

L<Paranoid::Debug>

=item o

L<Paranoid::IO>

=item o

L<Paranoid::IO::Lockfile>

=back

=head1 BUGS AND LIMITATIONS

B<-Filename> is interpreted differently depending on whether you're using an
environment or not.  If you're using this module as a standalone DB object any
relative paths are interpreted according to your current working directory.
If you are using an environment, however, it is interpreted relative to that
environment's B<-Home>.

=head1 SEE ALSO

    L<BerkeleyDB(3)>, L<Paranoid::BerkeleyDB::Env>,
    L<Paranoid::BerkeleyDB::Db>

=head1 HISTORY

02/12/2016  Complete rewrite

=head1 AUTHOR

Arthur Corliss (corliss@digitalmages.com)

=head1 LICENSE AND COPYRIGHT

This software is licensed under the same terms as Perl, itself. 
Please see http://dev.perl.org/licenses/ for more information.

(c) 2005 - 2016, Arthur Corliss (corliss@digitalmages.com)

