package Lock;
# This package contains the locking primitives.  Once I had 2 things that
# needed locking I decided to use these...

use strict;
use Symbol;
use Carp;
use Fcntl qw(LOCK_EX LOCK_NB);
use vars qw(
  $lock_dir $text_lock $text_unlock $timeout_limit $verbose
);
$verbose ||=0;

# The default lockfile
$lock_dir = "/set/your/default/here";

# The default text for the lock file when it is in use:
$text_lock = <<EOT;
  This file is for locking access to the production machines.  Please do
  not delete or rename it as that may mess up flocks.

  It is currently in use by $0 (process id $$) so it is really important
  not to disturb it now.
EOT


# The default text for the lock file when it is not in use:
$text_unlock = <<EOT;
  This file is for locking access to the production machines.  Please do
  not delete or rename it as that may mess up flocks.

  If it was being used it would say which process had it locked.
EOT

# By default $timeout_limit is undef which means forever.

# Truncates a file.  (Used for clearing the contents of a lock-file)
sub clear_file {
  local *FOO = shift;
  my $file = shift;
  seek (FOO, 0, 0) or confess("Cannot seek to beginning of $file: $!\n");
  truncate (FOO, 0) or confess("Cannot truncate $file: $!\n");
}

sub Drop {
  my $obj = shift;
  if ($obj->{is_dropped}) {
    croak("Attempting to drop a lock on $obj->{lockfile} twice!\n");
  }
  else {
    $obj->{is_dropped} = 1;
  }
  my $fh = $obj->{fh};
  &clear_file($fh, $obj->{lock_file});
  print $fh $obj->{text_unlock};
  close $fh; # The right way to drop
  if ($verbose) {
    print "Unlocked lock on $obj->{lock_dir}/$obj->{lock_file}\n";
  }
}

sub DESTROY {
  my $obj = shift;
  unless ($obj->{is_dropped}) {
    $obj->Drop;
  }
}

# Gets a lock.  The constructor passes it a hash of arguments.  Here are
# current possibilities:
#
#  lock_dir - the base directory for the lockfile to go in
#  lock_file - the file you need to lock.
#  no_block - return false if you would have to wait for a lock
#  text_lock - use this text in the lockfile while the file is locked
#  text_unlock - leave this text in the lockfile when you are done
#  timeout_limit - Try every second for this many seconds before failing
#
# Only lock_file is required.
sub Get {
  my $class = shift;
  my $obj;
  %$obj = @_;

  # Validation here
  unless ($obj->{lock_file}) {
    croak("No lock_file was requested!\n");
  }
  my %is_allowed = map {($_, 1)} qw/
    lock_dir lock_file no_block text_lock text_unlock timeout_limit
  /;
  foreach my $arg (keys %$obj) {
    unless (exists $is_allowed{$arg}) {
      croak("Unknown argument $arg");
    }
  }
  $obj->{lock_dir} ||= $lock_dir;
  $obj->{text_lock} ||= $text_lock;
  $obj->{text_unlock} ||= $text_unlock;
  my $lockfile = "$obj->{lock_dir}/$obj->{lock_file}";
  my $fh = $obj->{fh} = gensym();

  if ($verbose) {
    print "Getting lock on $lockfile\n";
  }

  my $open_cmd = "+< $lockfile";
  unless  (-e $lockfile) {
    print STDERR "$lockfile not found!  Creating\n";
    local *FH;
    open (FH, ">> $lockfile") or confess("Cannot create $lockfile! $!");
     close(FH);
    sleep 1;
  }

  open ($fh, "+< $lockfile") or confess("Cannot open $lockfile! $!");
  if (-l $fh) {
    confess("Refusing to use symlink '$lockfile' as a lockfile.");
  }
  if ($obj->{no_block}) {
    # test_only
    unless( flock ($fh, LOCK_EX | LOCK_NB)) {
      if ($verbose) {
        print "Failed to get lock on $lockfile\n";
      }
      return ();
    }
  }
  elsif (defined($timeout_limit)) {
    # Test every second until we hit the limit.
    my $limit = time + $timeout_limit;
    until (flock ($fh, LOCK_EX | LOCK_NB)) {
      if ($limit < time) {
        if ($verbose) {
          print "Failed to get lock on $lockfile within $timeout_limit\n";
        }
        return ();
      }
      sleep 1;
    }
  }
  else {
    flock ($fh, LOCK_EX) or confess("Cannot get lock! $!");
  }
  &clear_file($fh, $lockfile);

  # Set autoflush and print lock message
  my $old_fh = select ($fh);
  $| = 1;
  select ($old_fh);
  print $fh $obj->{text_lock};
  bless ($obj, $class);
}
1;