#!/usr/bin/perl -w
#
# run1 - Run a program once at a time
#
# LIMITATIONS - Please note that this script will only work reliably
# when the lock directory is on a filesystem (and operating system)
# where you can rely on open() with O_EXCL and flock() working properly.  
# In other words, don't point the lock directory to a network filesystem
# (especially NFS).  Use "-d /some/local/dir".
#
####
#
# Copyright (C) 2001-2002 Steven Pritchard <steve@silug.org>
# This program is free software; you can redistribute it
# and/or modify it under the same terms as Perl itself.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
#
# $Id: run1,v 1.10 2002/09/12 15:49:29 steve Exp $

use strict;

use Getopt::Std;
use FileHandle;
use Fcntl qw(:flock);
use POSIX;# qw(pause :sys_wait_h :errno_h);

use vars qw(%opt $break $debug);
use vars qw($warntime $killtime $lockdir $label $lockfile $lfh $count $shared);

sub debug(@);
sub basename($);
sub open_and_lock($$);

getopts('d:l:w:k:s', \%opt);

if (!@ARGV) {
    print STDERR "usage: " . basename($0) . " <args> [ <arguments> ]\n";
    exit 0;
}

if (defined($ENV{'DEBUG'})) {
    $debug=1;
} else {
    $debug=0;
}

$break=0;

if (defined($opt{'w'})) {
    $warntime=$opt{'w'};
} else {
    $warntime=86400; # One day.
}

if (defined($opt{'k'})) {
    $killtime=$opt{'k'};
} else {
    $killtime=0; # Never
}

$lockdir=$opt{'d'} || (getpwuid($<))[7] . "/.locks";

if (!-d $lockdir) {
    mkdir $lockdir, 0755;
    my $status=$!;
    die "Failed to create $lockdir: $status\n" if (!-d $lockdir);
}

if (defined($opt{'s'})) {
    $shared=1;
} else {
    $shared=0;
}

$label=basename($opt{'l'}) || basename($ARGV[0]);
$label=~s/[^\w\.\-]//g;
die "invalid label" if (!$label);
$lockfile="$lockdir/$label";

$count=0;

$lfh=open_and_lock($lockfile, $shared);

print $lfh "$$\n";
$lfh->flush;
eval { $lfh->sync }; # This currently (5.6.0) only works on some platforms.
debug "sync() failed on lockfile handle: $@" if ($@);

$SIG{'HUP'}=\&interrupt;
$SIG{'INT'}=\&interrupt;
$SIG{'QUIT'}=\&interrupt;
$SIG{'TERM'}=\&interrupt;
$SIG{'CHLD'}=sub { $break=0; };
$SIG{'ALRM'}=sub {};

my $pid=fork;
if ($pid==-1) {
    die "fork() failed: $!\n";
} elsif ($pid==0) {
    exec @ARGV;
    die "exec() failed: $!\n";
}

# There's a race here.  The child can exit between
# the kill() and pause(), and we'll wait forever.
# As a dirty, but hopefully effective, hack, let's
# arrange to receive a SIGALRM every 10 seconds.
while (kill 0, $pid) {
    alarm(10);
    POSIX::pause;
    kill($break, $pid) if ($break);
    waitpid($pid, &WNOHANG);
}

if ($shared) {
    # Try to get an exclusive lock.  If we
    # can, it is safe to remove the lock file.
    if (flock($lfh, LOCK_EX|LOCK_NB)) {
        unlink $lockfile or warn "Failed to unlink $lockfile: $!\n";
    } else {
        debug "Leaving active shared lock file $lockfile.\n",
	      "flock() error was '$!'";
    }
} else {
    unlink $lockfile or warn "Failed to unlink $lockfile: $!\n";
}

# We don't really care if these succeed,
# since we're just going to exit anyway.
flock($lfh, LOCK_UN);
close($lfh);
exit $?>>8;

sub debug(@)
{
    print STDERR @_, "\n" if ($debug);
}

sub interrupt
{
    ($break)=@_;
}

sub basename($)
{
    my ($arg)=@_;

    return "" if (!$arg);

    my @parts=split '/', $arg;

    return $parts[$#parts];
}

sub open_and_lock($$)
{
    my ($lockfile, $shared)=@_;
    my $lfh;

    $lfh=new FileHandle $lockfile, O_CREAT|O_WRONLY|O_EXCL;

    if (!defined($lfh)) {
        if ($!==EEXIST) {
	    # Either a process is running, or there is a stale pid/lock file.
	    $lfh=new FileHandle $lockfile, O_RDWR;
	    if (!defined($lfh)) {
	        if ($!==ENOENT) {
		    # The other process probably already exited.
		    return open_and_lock($lockfile, $shared);
	        } else {
		    die "Couldn't open lockfile $lockfile: $!\n";
	        }
	    }

	    my @oldpids;

	    while (<$lfh>) {
		$_+=0; # Make pid numeric.  Who needs chomp()?
	        push(@oldpids, $_);
	    }

	    if ($shared) {
	        if (flock($lfh, LOCK_SH|LOCK_NB)) {
		    # This sucks, because I'm not sure how we can figure
		    # out how many processes we share the lock with, if any.
		    debug "Got the lock, ",
		        (@oldpids
			    ? "possibly shared with pid(s) @oldpids."
			    : "but the previous owner is unknown?!");
		    seek($lfh, 0, 2); # Seek to the end of the file.
		} else {
		    die "Couldn't get a shared lock on $lockfile: $!\n";
		}
	    } elsif (flock($lfh, LOCK_EX|LOCK_NB)) {
	        # Got the lock - pid/lock file is stale.
	        print STDERR "Forcing stale lock",
		    (@oldpids ? " from process(es) @oldpids" : ""), ".\n";
	        truncate($lfh, 0);
	    } else {
	        # Couldn't get the lock - process must be running.
		if (@oldpids) {
	            debug "pid(s) @oldpids seem(s) to be running.";
	            my @buf=stat($lfh);
	            if ($killtime && (time>$buf[9]+$killtime)) {
		        if ($count>10) {
		            print STDERR
			        "PID(s) @oldpids won't die!  Giving up...\n";
		            exit 1;
		        }
			for my $oldpid (@oldpids) {
			    next if (!kill(0, $oldpid));

			    debug "$oldpid is apparently still running.";
		            print STDERR "killing pid $oldpid...\n";
		            die "Couldn't send TERM signal to pid $oldpid: $!\n"
		                if (!kill(15, $oldpid));
			}
		        sleep(2);
		        $count++;
		        return open_and_lock($lockfile, $shared);
	            } elsif ($warntime && (time>$buf[9]+$warntime)) {
		        print STDERR
			    "process(es) @oldpids have been running too long ",
			    "(since at least ",
			    scalar(localtime($buf[9])), ")\n";
	            } else {
	                debug "pid(s) @oldpids seem(s) to have started ",
		              scalar(localtime($buf[9])), ", maybe earlier";
	            }
		} else {
		    warn "lock $lockfile exists, but the owner is unknown!\n";
		}
	        exit 0;
	    }
        } else {
	    die "Couldn't create lockfile $lockfile: $!\n";
        }
    } else {
	if ($shared) {
            flock($lfh, LOCK_SH|LOCK_NB)
	        or die "Failed to lock $lockfile: $!\n";
	} else {
            flock($lfh, LOCK_EX|LOCK_NB)
	        or die "Failed to lock $lockfile: $!\n";
	}
    }

    return $lfh;
}

__END__

=head1 NAME

run1 - Run a program once at a time

=head1 SYNOPSIS

B<run1> [ C<-d> I<dir> ] [ C<-l> I<label> ] [ C<-w> I<sec> ] [ C<-k> I<sec> ]
     I<program> [ I<args> ]

=head1 DESCRIPTION

This program is useful for keeping multiple copies of a program from
running concurrently.

=head1 OPTIONS

=over 9

=item C<-d> I<directory>

Save lock/pid files in I<directory> instead of the default (~/.locks).

=item C<-l> I<label>

Use I<label> as the lock/pid file name.  The default is the name of the
program being executed.

=item C<-w> I<seconds>

Print a warning to stderr if the process with the lock has been running
for more than I<seconds> seconds.  The default is 86400 seconds, or one day.
Specifying 0 seconds disables warning messages.

=item C<-k> I<seconds>

Kill the process with the lock if it has been running for more than I<seconds>
seconds.  The default is 0, which disables this feature.

=item C<-s>

Try to get a shared lock on the lock file.  This is useful for nesting
calls to run1.  Say you have two scripts that can operate independently,
and another script that does the equivalent of the first two, in addition
to whatever other work it might do.  For example, a script that mirrors a
linux distribution ftp site.  One syncs only updates, the second syncs only
the distribution, and a third syncs the whole tree.  You might invoke them
like this:

    run1 -s -l mirror run1 mirror-updates
    run1 -s -l mirror run1 mirror-dist
    run1 -l mirror mirror-all

Since mirror-updates and mirror-dist get a shared lock on "mirror", they'll
keep mirror-all from running, but they'll run just fine individually.
While mirror-all is running, neither mirror-updates or mirror-dist will
run.

Note that currently -w and -k are ignored when using shared locks.  (This
may or may not change at some point in the future.)

=back

=head1 NOTES

Please note that this script will only work reliably when the lock
directory is on a filesystem (and operating system) where you can rely on
L<open(2)> with C<O_EXCL> and L<flock(2)> working properly.  In other
words, don't point the lock directory to a network filesystem (especially
NFS).  Use C<-d> I</some/local/dir>.

=head1 SEE ALSO

L<lockfile(1)>

=head1 BUGS

The limitations of the locking system (see L<NOTES|"NOTES"> above) could be
construed as bugs.

=head1 AUTHOR

Steven Pritchard E<lt>F<steve@silug.org>E<gt>

=cut