# PERL implementation of Erik E. Fair's 'shlock' (from the NNTP distribution)
# Ported by Brent Chapman <Brent@GreatCircle.COM>


# $Source: /sources/cvsrepos/majordomo/shlock.pl,v $
# $Revision: 1.1.1.2.6.2 $
# $Date: 1994/12/31 23:00:29 $
# $Author: rouilj $
# $State: Exp $
#
# $Locker:  $
# 

package shlock;

$shlock_debug = 0;

$EPERM = 1;
$ESRCH = 3;
$EEXIST = 17;

sub main'shlock	## Public
{
    local($file) = shift;
    local($tmp);
    local($retcode) = 0;
    local($redo_loop);

    print STDERR "trying lock \"$file\" for pid $$\n" if $shlock_debug;
    if (!($tmp = &xtmpfile($file))) {
	return(undef);
    }

    do {
	$redo_loop = 0;
	if (! link($tmp, $file)) {
	    if ($! == $EEXIST) {
		print STDERR "lock \"$file\" already exists\n" if $shlock_debug;
		$redo_loop = 1;
		if (&cklock($file)) {
		    print STDERR "extant lock is valid\n" if $shlock_debug;
		    $redo_loop = 0;
		} else {
		    print STDERR "lock is invalid; removing\n" if $shlock_debug;
		    if (unlink($file) <= 0) {
			warn("shlock: unlink(\"$file\"): $!");
		    }
		}
	    } else {
		warn("shlock: link(\"$tmp\", \"$file\"): $!");
	    }
	} else {
	    print STDERR "got lock \"$file\"\n" if $shlock_debug;
	    $retcode = 1;
	}
    } while ($redo_loop);

    if (unlink($tmp) <= 0) {
	warn("shlock: unlink(\"$file\"): $!");
    }
    return($retcode);
}

sub p_exists {
    local($pid) = shift;

    print STDERR "process $pid is " if $shlock_debug;
    if ($pid <= 0) {
	print STDERR "invalid\n" if $shlock_debug;
	return(0);
    }
    if (kill(0, $pid) <= 0) {
	if ($! == $ESRCH)
	    { print STDERR "dead\n" if $shlock_debug; return 0; }
	elsif ($! == $EPERM)
	    { print STDERR "alive\n" if $shlock_debug; return 1; }
	else
	    { print STDERR "state unknown: $!\n" if $shlock_debug; return 1; }
    }
    print "alive\n" if $shlock_debug;
    return 1;
}

sub cklock {
    local($file) = shift;
    local(*FILE, $len, $pid, $buf);

    print STDERR "checking extant lock \"$file\"\n" if $shlock_debug;
    if (!open(FILE, "$file")) {
	warn("shlock: open(\"$file\"): $!");
	return 1;
    }

    $buf = <FILE>;

    if (int($buf) <= 0) {
	close(FILE);
	print STDERR "lock file format error\n" if $shlock_debug;
	return 0;
    }
    close(FILE);
    return(&p_exists(int($buf)));
}

sub xtmpfile {
    local($file) = shift;
    local(*FILE);
    local($tempname);
    local($redo_loop);

    $tempname = $file;
    if ($tempname =~ /\//) {
	$tempname =~ s,/[^\/]*$,/,;
	$tempname .= "shlock.$$";
    } else {
	$tempname = "shlock.$$";
    }
    print STDERR "temporary filename \"$tempname\"\n" if $shlock_debug;

    do {
	$redo_loop = 0;
	if ( -e $tempname ) {
	    	print STDERR "file \"$tempname\" exists\n" if $shlock_debug;
		if (unlink($tempname) <= 0) {
		    warn("shlock: unlink(\"$tempname\"): $!");
		    return(undef);
		}
		$redo_loop = 1;
	} else { # open the file.
                &main'open_temp(FILE, $tempname); # if there are errors,
		                                 # open_temp will abort
	}
    } while ($redo_loop);

    if (! print FILE "$$\n") {
	warn("shlock failed: write(\"$tempfile\", \"$$\"): $!");
	close(FILE);
	unlink($tempname) || warn("shlock: unlink(\"$tempname\"): $!");
	return(undef);
    }

    close(FILE);

    sleep(15) if $shlock_debug; # give me a chance to look at the lock file

    return($tempname);
}

# open a file locked for exclusive access; we remember the name of the lock
# file, so that we can delete it when we close the file

sub main'lopen {
    local($FH) = shift;
    local($mode) = shift;
    local($file) = shift;
    # $fm is what will actually get passed to open()
    local($fm) = "$mode$file";
    local($status);
    local($tries);

    # create name for lock file
    local($lockfile) = $file;
    $lockfile =~ s,([^/]*)$,L.$1,;

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^']+$/$package'$&/;

    for ($tries = 0 ; $tries < 600 ; $tries++) {
	# Try to obtain the lock 600 times, waiting 1 second after each try
	if (&main'shlock("$lockfile")) {
	    # Got the lock; now try to open the file
	    $status = open($FH, $fm);
	    if (defined($status)) {
		# File successfully opened; remember the lock file for deletion
		$lock_files[fileno($FH)] = "$lockfile";
	    } else {
		# File wasn't successfully opened; delete the lock
		unlink("$lockfile");
	    }
	    # return the success or failure of the open
	    return($status);
	} else {
	    # didn't get the lock; wait 1 second and try again.
	    sleep(1);
	}
    }
    # If we get this far, we ran out of tries on the lock.
    return undef;
}

# reopen a file already opened and locked (probably to change read/write mode).
# We remember the name of the lock file, so that we can delete it when
# we close the file

sub main'lreopen {
    local($FH) = shift;
    local($mode) = shift;
    local($file) = shift;
    # $fm is what will actually get passed to open()
    local($fm) = "$mode$file";

    # create name for lock file
    local($lockfile) = $file;
    $lockfile =~ s,([^/]*)$,L.$1,;

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^']+$/$package'$&/;

    # close the old file handle, and delete the lock reference
    if ($lock_files[fileno($FH)]) {
	undef($lock_files[fileno($FH)]);
	close($FH);
    } else {
	# the file wasn't already locked
	# unlink("$lockfile");		### Do we really want to do this?
	return(undef);
    }

    # We've already got the lock; now try to open the file
    $status = open($FH, $fm);
    if (defined($status)) {
	# File successfully opened; remember the lock file for deletion
	$lock_files[fileno($FH)] = "$lockfile";
    } else {
	# File wasn't successfully opened; delete the lock
	unlink("$lockfile");
    }
    # return the success or failure of the open
    return($status);
}


# Close a locked file, deleting the corresponding .lock file.
sub main'lclose {
    local($FH) = shift;

    # force unqualified filehandles into callers' package
    local($package) = caller;
    $FH =~ s/^[^']+$/$package'$&/;

    local($lock) = $lock_files[fileno($FH)];
    close($FH);
    unlink($lock);
}

1;