package Lock;
# This package contains the locking primitives.  Once I had 2 things t
+hat
# 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 importa
+nt
  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 a
+re
# 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 faili
+ng
#
# 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;
[download]