# Paranoid::BerkeleyDB -- BerkeleyDB Wrapper
#
# (c) 2005 - 2015, Arthur Corliss <corliss@digitalmages.com>
#
# $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__
=head1 NAME
Paranoid::BerkeleyDB -- BerkeleyDB Wrapper
=head1 VERSION
$Id: lib/Paranoid/BerkeleyDB.pm, 2.02 2016/06/21 19:51:06 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)