File Coverage

blib/lib/DotLock.pm

Criterion	Covered	Total	%
statement	9	182	4.9
branch	0	94	0.0
condition	0	6	0.0
subroutine	3	20	15.0
pod	10	10	100.0
total	22	312	7.0

package DotLock;
require 5.002;

# DotLock user documentation in POD format is at end of this file.  Search for =head

use strict;
use vars qw($VERSION);
use POSIX qw(uname);

$VERSION = "1.06";

sub new
{
	my($self,%args) = @_;

		# Create new object, load it with defaults.

	$self = {
		timeout		=> 60,
		path		=> "",
		errmode		=> "die",
		maxqueue	=> 0,
		retrytime	=> 1,
		domain		=> "",
	};

		# Our marker to this object

	bless $self;

		# Parse Args and load object

		# errmode must be set first to allow the data methods error escaping.

	foreach(keys %args) {
		if(/^-?errmode$/i) {
			$self->errmode($args{$_});
		} elsif (/^-?timeout$/i) {
			$self->timeout($args{$_});
		} elsif (/^-?path$/i) {
			$self->path($args{$_});
		} elsif (/^-?maxqueue$/i) {
			$self->maxqueue($args{$_});
		} elsif (/^-?retrytime$/i) {
			$self->retrytime($args{$_});
		} elsif (/^-?domain$/i) {
			$self->domain($args{$_});
		};
	};

	$self;
};

sub lock
{
	my($self) = @_;
	my(@locktarget);

		# Vars

	my $locktarget = $self->path;
	my $locktargetfname;
	my $lockfiledir;
	if(-f $locktarget) {
		my @locktarget = split("\/", $locktarget);
		$locktargetfname = pop(@locktarget);
		$lockfiledir = "\/" . join("\/", @locktarget);
		push(@locktarget, "." . $locktargetfname);
		$locktarget = "\/" . join("\/", @locktarget);
	} elsif (!-d $locktarget) {
		$self->_error("Lock target doesn't exist");
		return undef;
	};
	my $lockfile = $locktarget . ".swp";
	my $domain = $self->domain;
	my $host = (POSIX::uname())[1];
	$host =~ s/\.$domain// if(length $domain);
	my $templockfile = $lockfile . ".$$-" . rand(1000) . ".$host";
	my $maxqueue = $self->maxqueue;
	my $timeout = $self->timeout;
	my $retrytime = $self->retrytime;

		# Open temp lockfile

	unless(open L, "> $templockfile") {
		$self->_error("Can't open lock file $templockfile: $!");
		return undef;
	};
	$self->_add_openfiles("$templockfile");

		# Make contents informative
		# what else can I add?

	print L "This lockfile was created by DotLock version $VERSION\n\n";
	print L "Host: " . $host . "\n";
	print L "Pid: $$\n";

		# Close and save temp lockfile

	unless(close L) {
		$self->_error("Can't write lock file $templockfile: $!");
		return undef;
	};

		# We must read the dir in, find the highest lockfile in the que, and lock one higher.

		# If by the time we have read the dir, if someone tries to obtain that same lock ... we climb the que
		# until something is free. This creates a small race condition which is only evident with fast locking.
		# There is a better way I plan to do this, however at this point it means the loss of a feature -
		# thoughts still ticking.

	opendir(LOCKFILEDIR, $lockfiledir);
	my @lockfiledir = readdir(LOCKFILEDIR);
	closedir(LOCKFILEDIR);

		# Find the highest free lock

	my $highestlock = 0;
	my $mainlock = 0;
	foreach (@lockfiledir) {
		if(/^$locktargetfname\.lock_(\d)$/) {
			# A qued lockfile
			if($1 > $highestlock) {
				$highestlock = $1;
			};
		};
	};
	my $freelock = $highestlock + 1;

		# Handle if queing is switched off

	if(($maxqueue == 0) and ($highestlock == 0)) {
		# Hmmm, there is no-one waiting to obtain a lock, try to get the master
		if(link($templockfile, $lockfile)) {
			# We have the master
			$self->_add_openfiles($lockfile);
			unlink($templockfile) && $self->_del_openfiles($templockfile);
			return(1);
		} else {
			#No master ...
			unlink($templockfile) && $self->_del_openfiles($templockfile);
        		$self->_error("Could not obtain file lock, too many already queued: $lockfile");
			return(undef);
		};
	};

		# Now its time to attempt to get a place in the que

	my $currentplacing;
	for(my $order = $freelock; $order <= $maxqueue; $order++) {
		if(link($templockfile, $lockfile . "_" . $order)) {

			$self->_add_openfiles($lockfile . "_" . $order);
			$currentplacing = $order;

				# We have qued successfully, now lets move up the que

			alarm($timeout);
			for(my $downque = $currentplacing - 1; $downque >= 1; $downque--) {

					# Clear lock files if alarmed ...

				local $SIG{ALRM} = sub {
					unlink($templockfile) && $self->_del_openfiles($templockfile);
					unlink($lockfile . "_" . $currentplacing) && $self->_del_openfiles($lockfile . "_" . $currentplacing);
					$self->_error("Timed out acheiving lock: $lockfile");
					return undef;
				};
				while(!link($templockfile, $lockfile . "_" . $downque)) {
					sleep($retrytime);
				};
				$self->_add_openfiles($lockfile . "_" . $downque);

					# We have the next position, lets remove the old possy and move the marker

				unlink($lockfile . "_" . $currentplacing) && $self->_del_openfiles($lockfile . "_" . $currentplacing);
				$currentplacing = $downque;
			};

				# Now first in line ... start trying to get the main lock

				# Clear lock files if alarmed ...

			local $SIG{ALRM} = sub {
				unlink($templockfile) && $self->_del_openfiles($templockfile);
				unlink($lockfile . "_" . $currentplacing) && $self->_del_openfiles($lockfile . "_" . $currentplacing);
				$self->_error("Timed out acheiving lock: $lockfile");
				return undef;
			};
			while(!link($templockfile, $lockfile)) {
				sleep($retrytime);
			};
			$self->_add_openfiles("$lockfile");
			alarm(0);

				# Oh goodie, we have the main lock ... now clear the old temp lockfiles
				# and return a positive answer to user

			unlink($lockfile . "_" . $currentplacing) && $self->_del_openfiles($lockfile . "_" . $currentplacing);
			unlink($templockfile) && $self->_del_openfiles($templockfile);
			return(1);
		};
	};

		# Too many waiting to que ... abort and clear files

	unlink($templockfile) && $self->_del_openfiles($templockfile);
	$self->_error("Could not obtain file lock, too many already queued: $lockfile");
	return undef;
};

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

	foreach(@{$self->_get_openfiles}) {
		unlink($_) && $self->_del_openfiles($_);
	};
};

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

	my $prev = $self->{timeout};

	if (@_ >= 2)
	{
		if($timeout > 0)
		{
			$self->{timeout} = $timeout;
		};
	};

	$prev;
};

sub path {
	my($self, $target) = @_;

	my $prev = $self->{path};



	if (@_ >= 2) {
		if(length $target)
		{
			if(-d $target) {
				if($target !~ /\/$/) {
					$target = $target . "/";
				};
			} elsif(!-f $target) {
				$self->_error("Path $target does not exist");
				return undef;
			};

			$self->{path} = $target;
		}
	}

	$prev;
}

sub errmode
{
	my($self, $args) = @_;
	my($prev);

	$prev = $self->{errmode};

	if(@_ >= 2) {
		if (($args eq "die") or ($args eq "return")) {
			$self->{errmode} = $args;
		};
	};

	$prev;
}

sub maxqueue
{
	my($self, $args) = @_;
	my($prev);

	$prev = $self->{maxqueue};

	if(@_ >= 2) {
		unless($args < 0) {
			$self->{maxqueue} = $args;
		};
	};

	$prev;
};

sub retrytime
{
	my($self, $args) = @_;
	my($prev);

	$prev = $self->{retrytime};

	if(@_ >= 2) {
		unless($args < 0) {
			$self->{retrytime} = $args;
		};
	};

	$prev;
};

sub domain
{
    my($self, $args) = @_;
    my($prev);

    $prev = $self->{domain};

    if(@_ >= 2) {
		$self->{domain} = $args;
    };

    $prev;
};

sub _error
{
	my($self, @errmsg) = @_;

	my $errmsg = join('', @errmsg);

	if($self->errmode eq "die") {
		$self->unlock;
		die($errmsg);
	} elsif ($self->errmode eq "return") {
		$self->errmsg($errmsg);
	};

	return(1);
};

sub errmsg
{
	my($self, @errmsg) = @_;
	my($prev);

	$prev = $self->{errmsg};

        my $errmsg = join('', @errmsg);

        if (@_ >= 2) {
		if(length $errmsg)
		{
			$self->{errmsg} = $errmsg;
		};
	};

	$prev;
};

sub _add_openfiles
{
	my($self,@files) = @_;

	if(@_ >= 2) {
		foreach(@files) {
			$self->{openfiles} {$_} = 1;
		};
	};

	1;
};

sub _get_openfiles
{
	my($self) = @_;
	my @openfiles;

	foreach(keys %{$self->{openfiles}}) {
		push(@openfiles, $_);
	};

	return(\@openfiles);
};

sub _del_openfiles
{
	my($self,@files) = @_;

	if(@_ >= 2) {
		foreach(@files) {
			delete($self->{openfiles} {$_});
		};
	};

	1;
};

sub DESTROY
{
	my $self = shift;

	$self->unlock;
};

1;

__END__;