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

#####################################################################
#
# 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.02 $ =~ /(\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__

=head1 NAME

Paranoid::BerkeleyDB::Env -- BerkeleyDB CDS Env Object

=head1 VERSION

$Id: lib/Paranoid/BerkeleyDB/Env.pm, 2.02 2016/06/21 19:51:06 acorliss Exp $

=head1 SYNOPSIS

  $db = Paranoid::BerkeleyDB::Env->new(-Home => './dbdir');

  $env = $dbe->env;
  @dbs = $dbe->dbs;

=head1 DESCRIPTION

This module provides an OO-based wrapper for the BerkeleyDB::Env class.

While this class places no restrictions on the use of any available
L<BerkeleyDB::Env(3)> options it does automatically deploy some defaults 
options oriented towards CDS access.  These can be overridden, but if you're 
focused on CDS this will simplify their use.

=head1 SUBROUTINES/METHODS

=head2 new

  $db = Paranoid::BerkeleyDB::Env->new(-Home => './dbdir');

The only required argument is B<-Home>.  For a complete list of all available
options please see the L<BerkeleyDB(3)> man page.

By default the following settings are applied unless overridden:

    Parameter   Value
    ---------------------------------------------------
    -Flags      DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL
    -ErrFile    {-Home}/db_err.log
    -Verbose    1

=head2 env

  $env = $dbe->env;

This returns a handle to the current L<BerkeleyDB::Env(3)> object.  Calling 
this in a child will cause the class to automatically reopen an object to 
avoid conflicts with the parent process.

=head2 dbs

  @dbs = $dbe->dbs;

This method returns a list of objects currently using this environment.
Typically these will be L<Paranoid::BerkeleyDB::Db(3)> objects.

=head2 DESTROY

A DESTROY method is provided which should sync and close an open database, as
well as release any locks.

=head1 DEPENDENCIES

=over

=item o

L<BerkeleyDB>

=item o

L<Class::EHierarchy>

=item o

L<Fcntl>

=item o

L<Paranoid>

=item o

L<Paranoid::Debug>

=item o

L<Paranoid::IO>

=item o

L<Paranoid::IO::Lockfile>

=back

=head1 BUGS AND LIMITATIONS

Race conditions, particularly on environment creation/opens, are worked 
around by the use of external lock files and B<flock> advisory file locks.  
Lockfiles are not used during normal operations on the environment.

While CDS allows for safe concurrent use of database files, it makes no
allowances for recovery from stale locks.  If a process exits badly and fails
to release a write lock (which causes all other process operations to block
indefinitely) you have to intervene manually.  The brute force intervention
would mean killing all accessing processes and deleting the environment files
(files in the same directory call __db.*).  Those will be recreated by the
next process to access them.

Berkeley DB provides a handy CLI utility called L<db_stat(1)>.  It can provide
some statistics on your shared database environment via invocation like so:

  db_stat -m -h .

The last argument, of course, is the directory in which the environment was
created.  The example above would work fine if your working directory was that
directory.

You can also show all existing locks via:

    db_stat -N -Co -h .

=head1 SEE ALSO

    L<BerkeleyDB(3)>

=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)

