Simple Locking

[tilly]

Category:

Miscellaneous

Description:

A simple module to implement locking. Check the documentation for flock on your system then make line 15 something appropriate and use it. (I am not kidding about the documentation - for instance on Linux you should not try to use flock on a directory mounted through NFS.) This is in essence a followup on the common mistakes that were brought up in RE: RE: Flock Subroutine.

The simplest and most common use is:

my $lock = Get Lock(lock_file => "foo.lock");

This blocks until you get that lock in your default locking directory. The contents of that file will by default say who currently has it locked.

Just drop the variable when you want to drop the lock. (What could be easier?) Look at the Get function to see what other useful options there are. For debugging or interactive use you may want to set $Lock::verbose to a true value.

Oops, a security hole. I made the following rather important edit:

--- lock1.pm    Thu Aug 17 11:38:20 2000
+++ lock2.pm    Thu Aug 17 11:41:04 2000
@@ -108,12 +108,15 @@
   unless  (-e $lockfile) {
     print STDERR "$lockfile not found!  Creating\n";
     local *FH;
-    open (FH, "> $lockfile") or confess("Cannot create $lockfile! $!"
+);
+    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)) {

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;