File Coverage

blib/lib/Tie/Concurrent.pm

Criterion	Covered	Total	%
statement	12	79	15.1
branch	0	24	0.0
condition	0	6	0.0
subroutine	4	13	30.7
pod			n/a
total	16	122	13.1

package Tie::Concurrent;

use strict;
use vars qw($VERSION);
use Carp;
use POSIX qw(:errno_h);
$VERSION = '0.05';

sub DEBUG () {0}

#######################################################
sub TIEHASH
{
    my($package, $self)=@_;

    unless($self->{READER} and $self->{WRITER}) {
        croak __PACKAGE__, "::TIEHASH needs READER and WRITER params";
    }
    my $p;

    foreach my $type (qw(READER WRITER)) {
        ($self->{$type.'_MODULE'}, @{$self->{$type}})=@{$self->{$type}};
    }
    return bless $self, $package;
}

#######################################################
sub _tie
{
    my($self, $type)=@_;
    my $data;
    my $tries=10;
    do {
        $data=eval {$self->{$type."_MODULE"}->TIEHASH(@{$self->{$type}})};
        if(not $data) {
            if($! != EAGAIN) {
                warn qq($self->{$type."_MODULE"}->TIEHASH(@{$self->{$type}}) failed: $!\n$@);
                return;
            }
            warn "$$: $tries attemps";
            $tries--;
            sleep 1;
        }
    } while(not $data and $tries > 0);
    return $data;
}

#######################################################
sub FETCH
{
    my $self=shift;

    my $data=$self->_tie('READER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;
    return $data->FETCH(@_);
}

#######################################################
sub EXISTS
{
    my $self=shift;

    my $data=$self->_tie('READER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;
    return $data->EXISTS(@_);
}





#######################################################
sub STORE
{
    my $self=shift;

    DEBUG and warn "Storing ", join ', ', @_;

    my $data=$self->_tie('WRITER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;
    return $data->STORE(@_);
}

#######################################################
sub CLEAR
{
    my $self=shift;

    my $data=$self->_tie('WRITER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;
    return $data->CLEAR(@_);
}

#######################################################
sub DELETE
{
    my $self=shift;

    my $data=$self->_tie('WRITER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;
    my $rv=$data->FETCH(@_);        # work around a bug in MLDBM
    $data->DELETE(@_);
    return $rv;
}

#######################################################
sub FIRSTKEY
{
    my($self)=shift;
    my $data=$self->_tie('READER');
    croak "$$: Unable to tie data: $! ($@)" unless $data;

    $self->{_keys}=[];
    my $q=$data->FIRSTKEY;
    DEBUG and warn "first key=$q";
    while(defined $q) {
        push @{$self->{_keys}}, $q;
        $q=$data->NEXTKEY($q);
        DEBUG and warn "next key=$q" if defined $q;
    }
    return $self->NEXTKEY;
}

#######################################################
sub NEXTKEY
{
    my($self)=shift;
    return unless $self->{_keys};
    my $rv=shift @{$self->{_keys}};
    delete $self->{_keys} if 0==@{$self->{_keys}};
    return $rv;
}



1;
__END__