File Coverage

blib/lib/Paranoid/BerkeleyDB/Core.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

# Paranoid::BerkeleyDB::Db -- Paranoid BerkeleyDB Core
#
# (c) 2005 - 2015, Arthur Corliss
#
# $Id: lib/Paranoid/BerkeleyDB/Core.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::Core;

use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Paranoid;
use Paranoid::Debug qw(:all);
use BerkeleyDB;
use Exporter;

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

@ISA = qw(Exporter);

@EXPORT    = qw(_addBlacklist _installScreener);
@EXPORT_OK = @EXPORT;

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

{
    our @blacklist;

    sub _addBlacklist {
        my @b = @_;

        push @blacklist, @b;

        return 1;
    }

    our @pkgs = qw(BerkeleyDB BerkeleyDB::Env BerkeleyDB::Hash
        BerkeleyDB::Btree BerkeleyDB::Heap BerkeleyDB::Recno
        BerkeleyDB::Queue BerkeleyDB::Unknown BerkeleyDB::_tiedHash
        BerkeleyDB::_tiedArray BerkeleyDB::Common BerkeleyDB::Cursor
        BerkeleyDB::TxnMgr BerkeleyDB::Txn );

    sub _chkBlacklist {

        # Purpose:  Calls the original DESTROY method if the object
        #           isn't on the blacklist
        # Returns:  Boolean;
        # Usage:    $rv = $obj->DESTROY;

        my $obj = shift;
        my $rv  = 1;
        my $u;

        pdebug( 'looking for %s in %s', PDLEVEL4, $obj, @blacklist );
        pIn();

        # Filter out undef entries
        # @blacklist = grep { defined $_ } @blacklist;
        $u = grep { !defined $_ } @blacklist;

        if ( defined $obj and !$u ) {
            if ( grep { $obj == $_ } @blacklist ) {
                pdebug( 'matched -- skipping DESTROY phase', PDLEVEL4 );
            } else {
                pdebug( 'no match -- executing DESTROY phase', PDLEVEL4 );
                $rv = $obj->_PDBDESTROY;
            }
        } elsif ($u) {
            pdebug( 'undefs in blacklist -- assume process exit', PDLEVEL4 );
            #$rv = $obj->_PDBDESTROY;
        }

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

        return $rv;
    }

    sub _installScreener {

        # Purpose:  Installs filter wrappers for DESTROY methods
        # Returns:  Boolean
        # Usage:    $rv = _installScreener();

        my ( $pkg, $tfqm, $dfqm, $code1, $code2 );

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

        $code2 = \&_chkBlacklist;

        foreach $pkg (@pkgs) {
            {

                # Wrap BerkeleyDB's DESTROY methods with
                # a filter sub

                no strict 'refs';
                no warnings qw(redefine prototype);

                $tfqm  = $pkg . '::DESTROY';
                $dfqm  = $pkg . '::_PDBDESTROY';
                $code1 = *{$tfqm}{CODE};

                # Make sure we haven't already done this
                next if !defined $code1 or $code1 == $code2;

                pdebug( 'installing filter for %s', PDLEVEL4, $tfqm );

                # Make the change
                *{$tfqm} = $code2;
                *{$dfqm} = $code1;
            }
        }

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

        return 1;
    }
}

1;

__END__