#!/usr/bin/perl

use strict;


# ==============================================================================
# Module-wide Information
# ==============================================================================


# ------------------------------------------------------------------------------
# Module name and description
# ------------------------------------------------------------------------------

package filelock;


# ------------------------------------------------------------------------------
# Modules we use
# ------------------------------------------------------------------------------

use Fcntl qw(:DEFAULT :flock);


# ------------------------------------------------------------------------------
# Constants (Operationally, if not technically)
# ------------------------------------------------------------------------------

my	$VERMAJ	= 1;						# Major version number ('1' in 'v1.02c')
my	$VERMIN = 10;						# Minor version number ('2' in 'v1.02c')
my	$VERSFX = '';						# Version suffix ('c' in 'v1.02c')

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

our	$RET_SUCCESS			= 0;
our	$RET_FAILURE			= (-1);
our	$RET_FATAL				= (-2);
our	$RET_ALREADYLOCKED		= (-3);
our	$RET_ALREADYUNLOCKED	= (-4);
our	$RET_NEGLOCKCNT			= (-5);
our	$RET_NEVERLOCKED		= (-6);

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=

my	$TRUE	= 1;
my	$FALSE	= 0;

my	$DFT_LCKEXT = '.lck';				# Default lock filename extension

my	$KEY_HIGHAN = 'HIGHAN';				# Master lock counter hash key
my	$KEY_LCKHAN = 'LCKHAN';				# Handle top-of-tree key
my	$KEY_LCKCNT = 'LCKCNT';				# Per-file Lock count top-of-tree key

my	$MST_LCKHAN = 'LCKFIL';				# Base portion of lock file handle

my	$NVRLCK = (-1);						# Magic lock count return flagging "never been locked"

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


# ------------------------------------------------------------------------------
# Globals
# ------------------------------------------------------------------------------

my	$Tstflg = 0;						# Are we in Unit Test mode?

my	%Lckhan;							# Lock token file handles

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


# ------------------------------------------------------------------------------
# Initializers
# ------------------------------------------------------------------------------


# ------------------------------------------------------------------------------
# None
# ------------------------------------------------------------------------------


# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


# ==============================================================================
# Subroutines
# ==============================================================================


# ------------------------------------------------------------------------------
# version() - Returns the version number of this module
# ------------------------------------------------------------------------------

sub version {
	return sprintf "%d.%02d%s", $VERMAJ, $VERMIN, $VERSFX;
}


# ------------------------------------------------------------------------------
# setTestMode($tstmod) - Sets (or clears) the unit test mode indicator
# 	$tstmod:	Whether or not test mode should be on
#
#	Returns:	The previous setting of the test mode
# ------------------------------------------------------------------------------

sub setTestMode {
	my ($tstmod, @arglst) = @_;

	my $oldmod = $Tstflg;
	$Tstflg = $tstmod;

	return $oldmod;
}


# ------------------------------------------------------------------------------
# getTestMode() - Returns the current test mode setting
#	Returns:	The current setting of the test mode
# ------------------------------------------------------------------------------

sub getTestMode {
	return $Tstflg;
}


# ------------------------------------------------------------------------------
# initLockCount($filfnm) - Initializes the lock count for a file
# 	$filfnm:	The filename to initement the lock counter
#
#	Returns:	The new lock counter (which will be 0)
#
# NOTE:  Also establishes the unique lock token file handle for this filename
# ------------------------------------------------------------------------------

sub initLockCount {
	my ($filfnm, @arglst) = @_;

	$Lckhan{$KEY_LCKCNT}{$filfnm} = 0;

	# If necessary, geneate unique lock handle and store.
	if (!defined $Lckhan{$KEY_HIGHAN}) {
		# No Lock handle counter.  Initialize.
		$Lckhan{$KEY_HIGHAN} = 0;
	}
	if (!defined $Lckhan{$KEY_LCKHAN}{$filfnm}) {
		$Lckhan{$KEY_HIGHAN}++;		# Unique lock handle number
		$Lckhan{$KEY_LCKHAN}{$filfnm} = $MST_LCKHAN . $Lckhan{$KEY_HIGHAN};
		#DEBUG print "Handle for '$filfnm' is ", $Lckhan{$KEY_LCKHAN}{$filfnm};
	}

	#DEBUG print "Lock count for '$filfnm' is now ", $Lckhan{$KEY_LCKCNT}{$filfnm};

	return $Lckhan{$KEY_LCKCNT}{$filfnm};
}


# ------------------------------------------------------------------------------
# incrLockCount($filfnm) - Increments the lock count for a file
# 	$filfnm:	The filename to increment the lock counter
#
#	Returns:	The new lock counter
# ------------------------------------------------------------------------------

sub incrLockCount {
	my ($filfnm, @arglst) = @_;

	my $lckcnt = getLockCount($filfnm);
	if ($lckcnt eq $NVRLCK) {
		$lckcnt = &initLockCount($filfnm);
	}
	$lckcnt++;
	$Lckhan{$KEY_LCKCNT}{$filfnm} = $lckcnt;

	return $lckcnt;
}


# ------------------------------------------------------------------------------
# decrLockCount($filfnm) - Decrements the lock count for a file
# 	$filfnm:	The filename to decrement the lock counter
#
#	Returns:	The new lock counter
# ------------------------------------------------------------------------------

sub decrLockCount {
	my ($filfnm, @arglst) = @_;

	my $lckcnt = $Lckhan{$KEY_LCKCNT}{$filfnm};
	$lckcnt--;
	$Lckhan{$KEY_LCKCNT}{$filfnm} = $lckcnt;

	return $lckcnt;
}


# ------------------------------------------------------------------------------
# getLockCount($filfnm) - Returns the current test mode setting
# 	$filfnm:	The filename to decrement the lock counter
#
#	Returns:	The current Lock Count for the file or $NVRLCK if never locked
# ------------------------------------------------------------------------------

sub getLockCount {
	my ($filfnm, @arglst) = @_;

	if (!defined $Lckhan{$KEY_LCKCNT}{$filfnm}) {
		# Not defined.  File has never been locked in this session.
		return $NVRLCK;
	} else {
		return $Lckhan{$KEY_LCKCNT}{$filfnm};
	}
}


# ------------------------------------------------------------------------------
# lock($filfnm) - Requests a lock token for a file
# 	$filfnm:	The filename to take out a lock upon
# 	Returns:	$RET_SUCCESS or an error number
# ------------------------------------------------------------------------------

sub lock() {
	my ($filfnm, @arglst) = @_;

	#DEBUG print "Process $$ attempting access";

	my $lckfnm = &_getLockFilename($filfnm);	# Lock token filename for this file

	# Increment lock counter
	my $lckcnt = &incrLockCount($filfnm);
	#DEBUG print "Lock count for '$filfnm' is now $lckcnt";

	# If this is the first lock, create and open the lock token file so flock() can grab it
	if ($lckcnt == 1) {
		# First lock.  Do lock token management.
		{
			# Must disable warnings and strict for this
			no warnings;
			no strict;

			if (!(sysopen($Lckhan{$KEY_LCKHAN}{$filfnm}, "$lckfnm", O_WRONLY | O_CREAT))) {
				# Error opening the lock token file.
				print "ERROR:  Cannot open lock file '$lckfnm' (Error: $!)\n";
				return $RET_BADOPEN;
			}
		}

		# Lock (and empty) the lock token file
		{
			# Must disable warnings and strict for this
			no warnings;
			no strict;

			if (!(flock($Lckhan{$KEY_LCKHAN}{$filfnm}, LOCK_EX))) {
				# Unable to get the atomic lock for some reason.
				print "ERROR:  Cannot lock lock file '$lckfnm' (Error: $!)\n";
				return $RET_BADLOCK;
			}
		}
		{
			# Must disable warnings and strict for this
			no warnings;
			no strict;

			if (!(truncate($Lckhan{$KEY_LCKHAN}{$filfnm}, 0))) {
				# Unable to truncate (possibly means lock failed)
				# Seems to fail under normal usage if the lockfile did not previously exist.
				# However, it functions correctly.  So don't report this error as an error.
				# So these next two commands are commented out for this reason.
				#print "ERROR:  Cannot truncate lock file '$lckfnm' (Error: $!)\n";
				#return $RET_BADTRUNCATE;
			}
		}
	}

	#DEBUG print "Process $$ has gained access";

	return $RET_SUCCESS;
}


# ------------------------------------------------------------------------------
# unlock($filfnm) - Releases a lock token for a file
# 	$filfnm:	The filename to release the lock for
# 	Returns:	$RET_SUCCESS or an error indicator
# ------------------------------------------------------------------------------

sub unlock() {
	my ($filfnm, @arglst) = @_;

	#DEBUG print "Process $$ is preparing to release";

	# First check and see if we have ever had it locked.
	my $lckcnt = &getLockCount($filfnm);
	if ($lckcnt eq $NVRLCK) {
		# Nope.  Slap da hand.
		return $RET_NEVERLOCKED;
	}

	# Then check and see if we have it locked now.
	if ($lckcnt <= 0) {
		# Nope.  Slap da hand.
		return $RET_ALREADYUNLOCKED;
	}

	# Decrement the lock counter
	$lckcnt = &decrLockCount($filfnm);
	#DEBUG print "Process $$ new lock count is $lckcnt";
	if ($lckcnt < 0) {
		# Impossible condition.  Lock counter gone negative??
		print "INTERNAL ERROR:  Lock counter for '$filfnm' is '$lckcnt'!!\n";
		return $RET_NEGLOCKCNT;
	}

	# If it's our last lock, release it.
	if (!$lckcnt) {
		# It's our last lock.  Release the lock token file.
		my $lckfnm = &_getLockFilename($filfnm);
		{
			# Must disable warnings and strict for this
			no warnings;
			no strict;

			close $Lckhan{$KEY_LCKHAN}{$filfnm};
		}
	}

	#DEBUG print "Process $$ has released ";

	return $RET_SUCCESS;
}




# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=


# ==============================================================================
# Internal Subroutines
# ==============================================================================


# ------------------------------------------------------------------------------
# _getLockFilename($filfnm) - Returns the lock token filename for a given file.
# 	$filfnm:	The filename for whom the lock token will be generated
# 	Returns:	The lock token filename for that file.
# ------------------------------------------------------------------------------

sub _getLockFilename {
	my ($filfnm, @arglst) = @_;

	my $lckfnm = $filfnm . $DFT_LCKEXT;		# Lock token filename

	return $lckfnm;
}


# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=



# ------------------------------------------------------------------------------
# Perl modules MUST return true
# ------------------------------------------------------------------------------

1;

__END__

# ------------------------------------------------------------------------------
# Update History:
#
# 	SKM	= Steven K. Mariner
#
# 23-Apr-2005	SKM		Initial writing									v0.10a
# 23-Apr-2005	SKM		Passes fundamental unit tests					v0.10a
# 24-Apr-2005	SKM		First release									v1.00
# 24-Apr-2005	SKM		Multiple locks are now stacked					v1.10
#
# ------------------------------------------------------------------------------
# To Do:
#
# ------------------------------------------------------------------------------
# Immediate Bug List:
#
# ------------------------------------------------------------------------------