File Coverage

blib/lib/LockFile/NetLock.pm

Criterion	Covered	Total	%
statement	26	107	24.3
branch	1	48	2.0
condition	0	24	0.0
subroutine	9	15	60.0
pod	4	5	80.0
total	40	199	20.1

######################################################################
# LockFile::NetLock
#
# Use ftp and directory creation to create mutual exclusion/locking
# available cross platform and on a network.  Based on an article
# by Sean M. Burke in the Summer 2002 Perl Journal.
#
# Basic idea is based on mutually exclusive property of creating
# directories via FTP.  The first process that asks to create the
# directory succeeds and later attempts are notified of failure
# because directory already exists.  FTP session is maintained
# by separate program called 'netlock' that automatically removes
# the directory if the creating program dies or requests removal.
# Communication between this module and netlock program is via an
# interprocess pipe.  On win32 systems some communication is also
# done via a mutex because pipes block too quickly and problems
# were encountered when trying other solutions.
#
# Implemented by Ronald Schmidt.
######################################################################

package LockFile::NetLock;

use strict;
use warnings;
require 5.006; # goes back a ways but does not seem to like 5.005
use Exporter;
use Config;
use Carp;
use FileHandle;
use POSIX qw(sys_wait_h signal_h);

our @ISA = qw/ Exporter /;
our @EXPORT_OK = qw(lock unlock);

our $VERSION = '0.32';

our $errstr;

my %named_lock;
my $mx_id = 0;
my $is_win32;

BEGIN {
        $is_win32 = ($^O =~ /win32/i);
        require Win32::Mutex if ($is_win32);
}

######################################################################
# new - Constructor method.
#
# Not much going on here - just setup of parameters that will be
# used by lock process.  Caller is allowed to pass up to four initial
# un-named parameters that are interpreted as ftp host, lock directory
# ftp user and password respectively.
######################################################################
sub new {
        my $self = shift;
        my $class = ref($self) || $self;

        use constant KNOWN_OPT => {
                map( ($_ => 1) , qw(
                        -dir -disconnect -ftp_heartbeat -heartbeat -host -idle
                        -password -sleep -timeout -user
                ))
        };

        my %ivar = (
                -host   =>      'localhost',
                -dir    =>      'lockdir'
        );

        # allow host, directory user and password to be passed unlabeled
        foreach (qw (-host -dir -user -password)) {
                last if ($_[0] && ($_[0] =~ /^\-/));
                $ivar{$_} = shift;
        }
        %ivar = (%ivar, @_);

        # empty parameters may cause trouble with ./netlock program
        grep(   $_ ne '-disconnect' && (! $ivar{$_}) && delete($ivar{$_}),
                (keys %ivar));

        foreach my $opt (keys %ivar) {
                carp("Unknown option: $opt") unless (KNOWN_OPT->{$opt});
        }

        return bless \%ivar, $class;
}

######################################################################
######################################################################
sub set_error {
        my $self = shift;
        $errstr = $self->{error} = shift;
}

######################################################################
# lock
#
# Call netlock program to use FTP to create a directory on a
# mutually exclusive basis if one has not been created.  Can
# be called using an existing LockFile::NetLock object reference
# or the parameters needed to create a new object can be passed
# to this method.
######################################################################
sub lock {
        my $self = ref($_[0]) && shift;
        my $lock_key;

        unless ($self) {
                $self = LockFile::NetLock->new(@_);
                $lock_key = "$self->{-host},$self->{-dir}";
                if ($named_lock{$lock_key}) {
                        $errstr = "Already locking $lock_key";
                        return;
                }
                $named_lock{$lock_key} = $self;
        }

        my ($cmd) = grep    { -r  && ! -d }
                            (   './netlock', "$Config{bin}/netlock",
                                "$Config{installsitescript}/netlock"
                            );
        my $cmd_line = $Config{perlpath};
        $cmd_line =~ s!/!\\!g if ($is_win32);
	$cmd_line .= " $cmd";

        $cmd_line .= ' -d' if $self->{-disconnect};

        # first character after - in package option is Getopt::Std prog option
        foreach my $opt (grep($_ !~ /^(-d|-host|-reader)/, keys %$self)) {
                $cmd_line .= ' ' . substr($opt, 0, 2) . $self->{$opt};
        }

        if ($is_win32) {
                $self->{mutex_name} = "netlock:$$:" . $mx_id++;
                unless ($self->{mutex} =
                                Win32::Mutex->new(1, $self->{mutex_name})) {
                        $self->set_error("Could not create mutex: $^E");
                        return;
                }
                $cmd_line .= " -m $self->{mutex_name}";
        }

        $cmd_line .= " $self->{-host} $self->{-dir}";
        my $fh = new FileHandle "$cmd_line |";

        unless ($fh) {
                $self->set_error("Could not start netlock process: $!");
                delete $named_lock{$lock_key} if ($lock_key);
                return;
        }

        $self->{filehandle} = $fh;
        my $from_netlock = <$fh>;
        if ($from_netlock !~ /^\.*OK/) {
                $self->set_error("Failed to acquire net lock: $from_netlock");
                return;
        }
        $self->{is_locked} = 1;

        return $self;
}


######################################################################
# unlock
#
# Close the handle to the running netlock process holding the lock
# uniquely identified by the host and directory or object containing
# those unique identifiers.  If we are not currently the locker, or
# an error happens on close, or we get a child exist code of -1
# indicating a netlock lock removal error we return an error code.
######################################################################
sub unlock {
        my $self = ref($_[0]) && shift;
        my $lock_key;

        unless ($self) {
                # bit of a hack - just want a standard way to get host and dir
                $self = LockFile::NetLock->new(@_);
                $lock_key = "$self->{-host},$self->{-dir}";
                $self = $named_lock{$lock_key};

                # once you try to unlock you can always try to lock again
                delete $named_lock{$lock_key};
        }

        unless ($self && $self->{filehandle}) {
                $errstr = "Cannot unlock: not currently locking";
                if ($lock_key) {
                        $errstr .= " $lock_key";
                }
                else {
                        $errstr .= ' object';
                }
                $self->{error} = $errstr if ($self);
                return;
        }

        if ($is_win32) {
                unless ($self->{mutex}->release) {
                        $self->set_error("Could not release mutex: $^E");
                }
        }

        my $close_rc;
        unless ($close_rc = close($self->{filehandle})) {
                $self->set_error("Failed to close lock process: $!");
        }

        if ($?) {
                my $reaped_rc = $? >> 8;
                if ($reaped_rc & 255 == 255) {
                        $self->set_error("Failed to remove lock directory.");
                }
                else {
                        $self->set_error("Unlock failure code: $reaped_rc");
                }
        }
        return unless($close_rc);
        $self->{is_locked} = 0;

        return 1;
}

######################################################################
# Return most recent error on object if passed an object reference
# otherwise most recent error against module.
######################################################################
sub errstr {
        my $self = shift;

        return ($self && ref($self) && $self->{error}) || $errstr;
}

######################################################################
# Needed for win32.  Without this exiting scope could
# attempt to close the process handle without releasing the mutex
# leading to deadlock.
######################################################################
sub DESTROY {
        my $self = shift;

        $self->{mutex}->release if (
                $is_win32 && $self->{is_locked}
        );
}

1;
__END__