File Coverage

blib/lib/Tie/MLDBM.pm

Criterion	Covered	Total	%
statement	12	72	16.6
branch	0	12	0.0
condition			n/a
subroutine	4	12	33.3
pod	0	1	0.0
total	16	97	16.4

package Tie::MLDBM;

use Carp;
use Tie::Hash;

use strict;
use vars qw/ @ISA $AUTOLOAD $VERSION /;

@ISA = qw/ Tie::Hash /;
$VERSION = '1.04';


sub AUTOLOAD {
    my ( $self, @params ) = @_;

    #   Parse method name from $AUTOLOAD variable and validate this method against
    #   a list of methods allowed to be accessed through the AUTOLOAD subroutine.

    my $method = $AUTOLOAD;
    $method =~ s/.*:://;

    my @methods = qw/ EXISTS FIRSTKEY NEXTKEY /;

    unless ( grep /\Q$method\E/, @methods ) {

        croak( __PACKAGE__, '->AUTOLOAD : Unsupported method for tied object - ', $method );

    }

    $self->{'Modules'}->{'Lock'}->lock_shared;

    my $rv = $self->{ 'Store' }->$method( @params );

    $self->{'Modules'}->{'Lock'}->unlock;

    return $rv;
}


sub CLEAR {
    my ( $self, @params ) = @_;

    #   Acquire an exclusive lock, execute the CLEAR method on the tied hash and
    #   synchronise the tied hash.  The synchronisation of this hash is performed
    #   by the Sync method of this class by way of re-opening the tied hash object
    #   and storing this object reference

    $self->{'Modules'}->{'Lock'}->lock_exclusive;

    my $rv = $self->{'Store'}->CLEAR( @params );

    $self->{'Modules'}->{'Lock'}->unlock;

    $self->Sync;

    return $rv;
}


sub DELETE {
    my ( $self, @params ) = @_;

    #   Acquire an exclusive lock and execute the DELETE method on the tied hash.

    $self->{'Modules'}->{'Lock'}->lock_exclusive;

    my $rv = $self->{'Store'}->DELETE( @params );

    $self->{'Modules'}->{'Lock'}->unlock;

    return $rv;
}


sub FETCH {
    my ( $self, $key ) = @_;

    #   Retrieve the value indexed by the passed key argument from the second-level
    #   tied hash.  This fetched value is then deserialised using the serialisation
    #   component module of the Tie::MLDBM framework and returned to the calling
    #   process.

    $self->{'Modules'}->{'Lock'}->lock_shared;

    my $value = $self->{'Store'}->FETCH( $key );

    $self->{'Modules'}->{'Lock'}->unlock;

    return $self->{'Modules'}->{'Serialise'}->deserialise( $value );
}


sub STORE {
    my ( $self, $key, $value ) = @_;

    #   Serialise the passed value argument using the serialisation component
    #   module of the Tie::MLDBM framework.  The result of this serialisation is
    #   stored in the second-level tied hash.

    $value = $self->{'Modules'}->{'Serialise'}->serialise( $value );

    $self->{'Modules'}->{'Lock'}->lock_exclusive;

    my $rv = $self->{'Store'}->STORE( $key, $value );

    $self->{'Modules'}->{'Lock'}->unlock;

    return $rv;
}


sub TIEHASH {
    my ( $class, $args, @params ) = @_;
    my $self = bless {}, $class;

    #   The first argument to the TIEHASH object constructor should be a hash
    #   reference which contains configuration options for this framework.  There
    #   is no strict checking of the elements of the passed hash so as to allow for
    #   the expansion of this framework and definition of additional configuration
    #   options for framework components.

    unless ( ref $args eq 'HASH' ) {

        croak( __PACKAGE__, '->TIEHASH : First argument to TIEHASH constructor should be a hash reference' );

    }

    #   The following simply cleans up the keys of the passed argument hash so that
    #   all keys are word-like with an uppercase first character and all lowercase
    #   for the remaining characters.
    #
    #   The result is stored in $self->{ 'Config' } so that these arguments can be
    #   accessed by component modules.

    $self->{'Config'} = { map { ucfirst lc $_ => delete ${$args}{$_} } keys %{$args} };

    #   The %modules hash contains a list of configuration parameters which may be
    #   specified within the hash reference argument to the TIEHASH object
    #   constructor.
    #
    #   The hash of configuration parameters are then iterated through and if any
    #   of the options specified in the %modules hash are present, the component
    #   module to which the configuration option refers (at this level of the
    #   Tie::MLDBM framework) is called upon.

    my %modules = (
        'Lock'          =>  'Null',
        'Serialise'     =>  undef,
        'Store'         =>  undef
    );

    foreach my $arg ( keys %modules ) {

        if ( exists $self->{'Config'}->{$arg} ) {

            $modules{$arg} = join '::', __PACKAGE__, $arg, $self->{'Config'}->{$arg};
            eval "require $modules{$arg}" or
                croak( __PACKAGE__, '->TIEHASH : Cannot include framework component module ', $modules{$arg}, ' - ', $! );

        }

    }

    $self->{'Modules'} = \%modules;

    #   The arguments passed to the TIEHASH method of this class are stored for
    #   re-use at a later stage after locking or CLEAR operations where the tied
    #   hash is synchronised.

    $self->{'Args'} = [ @params ];

    #   Create a second-level tie to the underlying storage mechanism for
    #   serialised data structures and store the tied object within the blessed
    #   package object.

    my $db;
    $db = $self->{'Modules'}->{'Store'}->TIEHASH( @{ $self->{'Args'} } ) or
        croak( __PACKAGE__, '->TIEHASH : Failed to tie second level hash object - ', $! );
    $self->{'Store'} = $db;

    return $self;
}


sub Sync {
    my ( $self ) = @_;

    #   The synchronisation of the tied hash is carried out in the same manner by
    #   which this is achieved in MLDBM::Sync.  This calls for the re-opening of
    #   the tied hash object and storing this object reference in the Tie::MLDBM
    #   class object.

    my $db;
    $db = $self->{'Modules'}->{'Store'}->TIEHASH( @{ $self->{'Args'} } ) or
        croak( __PACKAGE__, '->Sync : Failed to tie second level hash object - ', $! );
    $self->{'Store'} = $db;

    return $self;
}


sub UNTIE {
    my ( $self, @params ) = @_;
    return $self->{'Store'}->UNTIE( @params );
}


1;


__END__