view release on metacpan or  search on metacpan

lib/EMDIS/ECS/LockedHash.pm  view on Meta::CPAN

    if(!$this->TIED and !$this->_tie()) {
        $this->ERROR("EMDIS::ECS::LockedHash::lock() failed: " . $this->ERROR);
        return '';
    }
    return 1;  # successful
}

# ----------------------------------------------------------------------
# Release (advisory) lock and untie internal hash.
sub unlock {
    my $this = shift;
    $this->_untie();
    $this->_unlock();
}

# ----------------------------------------------------------------------
# Quickly delete all key-values under an exclusive lock
sub undef {
    my $this = shift;

    $this->ERROR('');  # reset error status
    # check lock status
    if($this->LOCK != LOCK_EX) {
        $this->ERROR("EMDIS::ECS::LockedHash::undef() requires exclusive lock.");
        return '';
    }
    # delete everything from hash
    undef %{$this->{hash}};
    return 1;  # successful
}


# ----------------------------------------------------------------------
# untie hash and close lock file when perl object passes out of scope
sub DESTROY {
    my $this = shift;
    $this->_untie();
    close($this->{FH_LOCK})
        if defined $this->{FH_LOCK};
}

# ----------------------------------------------------------------------
# Select UNIX or Win32 version of _lock
sub _lock
{
    $^O =~ /MSWin32/ ? _lock_win32(@_) : _lock_unix(@_);
}

# ----------------------------------------------------------------------
# Internal subroutine:  obtain (advisory) lock, using time limit to
# avoid indefinite blocking.  Returns true if able to obtain lock within
# time limit;  otherwise returns false.
sub _lock_unix {
    my $this = shift;
    my $lock_type = shift;
    $lock_type = LOCK_EX unless defined $lock_type;
    my $result = 1;

    # set up "local" SIG_ALRM handler
    # (Note:  not using "local $SIG{PIPE}" because it ignores die())
    my $oldsigalrm = $SIG{ALRM};
    $SIG{ALRM} = sub {
        die "timeout - $this->{lock_timeout} second time limit exceeded\n";
    };

    # attempt to obtain lock, with time limit
    eval {
        alarm($this->{lock_timeout});   # set alarm
        die "flock() failed: $!\n"
            unless flock($this->{FH_LOCK}, $lock_type);
# File::lockf -- potential alternate locking method:
#        my $status = File::lockf::lock($this->{FH_LOCK}, 0);
#        die "lockf failed: $status\n"
#            if $status != 0;
        alarm(0);  # turn off alarm
    };
    if($@) {
        alarm(0);  # turn off alarm
        $this->ERROR("EMDIS::ECS::LockedHash::_lock_unix() failed: $@");
        $this->LOCK(0);  # reset status indicator
        $result = '';
    }
    # restore previous SIG_ALRM handler
    if(defined $oldsigalrm) { $SIG{ALRM} = $oldsigalrm; }
    else                    { delete $SIG{ALRM}; }
    $this->LOCK($lock_type)   # set status indicator
        if $result;
    return $result;  # successful
}

# ----------------------------------------------------------------------
# Internal subroutine:  obtain (advisory) lock, using time limit to
# avoid indefinite blocking.  Returns true if able to obtain lock within
# time limit;  otherwise returns false.
sub _lock_win32 {
    my $this = shift;
    my $lock_type = shift;
    $lock_type = LOCK_EX unless defined $lock_type;
    my $result = 1;

    # attempt to obtain lock, with time limit
    # (uses polling method to obtain lock -- somewhat more crude than
    # the unix method, which uses blocking with SIGALRM to enforce timeout)
    my $timeoutCount = 0;
    my $locked;
    while (!($locked = flock($this->{FH_LOCK}, $lock_type | LOCK_NB)) and 
        ($timeoutCount++ <= $this->{lock_timeout})) {
	sleep 1;
    }

    if(!$locked) {
        $this->ERROR("EMDIS::ECS::LockedHash::_lock_win32() failed: $@");
        $this->LOCK(0);  # reset status indicator
        $result = '';
    }
    $this->LOCK($lock_type)   # set status indicator
        if $result;
    return $result;  # successful
}

# ----------------------------------------------------------------------
# Internal subroutine:  tie hash to db file
sub _tie {
    my $this = shift;
    $this->{db_obj} = tie(%{$this->{hash}}, 'SDBM_File', $this->{dbfile},
        O_CREAT|O_RDWR, (defined $EMDIS::ECS::FILEMODE ? $EMDIS::ECS::FILEMODE : 0664))
        or $this->ERROR(
            "EMDIS::ECS::LockedHash::_tie() failed ($this->{dbfile}): $!");
    if($this->{db_obj}) {
        $this->TIED(1);     # set status indicator
    } else {
        $this->TIED('');    # reset status indicator
    }
    return $this->TIED;
}

# ----------------------------------------------------------------------
# Internal subroutine:  release (advisory) lock
sub _unlock {
    my $this = shift;
    flock($this->{FH_LOCK}, LOCK_UN);
# File::lockf -- potential alternate locking method:
#    my $status = File::lockf::ulock($this->{FH_LOCK}, 0);
    $this->LOCK(0);      # reset status indicator