Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
There's more than one way to do things
 
PerlMonks  

Simple Locking

by tilly (Archbishop)
on Aug 08, 2000 at 23:03 UTC ( #26860=sourcecode: print w/ replies, xml ) Need Help??

Category: Miscellaneous
Author/Contact Info Ben Tilly
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;

Comment on Simple Locking
Download Code
RE: Simple Locking
by turnstep (Parson) on Aug 08, 2000 at 23:12 UTC

    How is this different from:

    • File::Lock
    • File::Flock
    • File::BasicFlock

    I havent't used any of those, just curious. :)

      When I wanted this, I could not find what I was looking for on CPAN. It may have been there, I just didn't see it. For instance if you go browse for descriptions on CPAN you will find that File::Flock and File::BasicFlock just are more sophisticated versions of the flock() command. So they do not implement the semantics that I wanted. The File::Lock module looked closer, but it had only a very simple OO interface that was not fired by destruction.

      In general all of the things I saw on CPAN were wrappers around the idea, "let us give better/more detailed ways to lock stuff" while I wanted, "Gimme an incredibly easy 'get a lock' semantic that I won't mess up on."

      However KM pointed out to me that the system call to "touch" is not the best approach if the file does not exist. I should really either do that in Perl or else use File::Flock.

      FWIW I use this for wrapping a lot of complex operations. For instance if I want a set of processes to go in order, I just have them start in order and attempt to grab a lock. They will not succeed until the previous process drops the lock. I can then combine this in some processes with a timeout_limit argument and send a page if it does not succeed...

        However KM pointed out to me that the system call to "touch" is not the best approach if the file does not exist.

        I said this simply becuase it isn't a safe way to use system(). If someone passes "/tmp/file; mail me@me.com < /etc/passwd" as $lockfile, there could be trouble. I would either use a safer system like:

        system("/bin/touch",$lockfile);

        Or, simply an open FH, ">>$lockfile" ... approach.

        Cheers,
        KM

RE (tilly) 1: Simple Locking
by tilly (Archbishop) on Aug 17, 2000 at 19:37 UTC
    I don't normally stop and think about security, but in the above I should have. KM already pointed out why using touch was bad. But apparently nobody noticed that I was opening and truncating files without testing whether they were not symlinks.

    Oops.

    I am posting a new node here describing the problem so that if anyone is using it and the oversight matters, they can know to change it. The two edits will be to create the lockfile if need be with append instead of overwrite, and to test the file I open for being a symlink.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://26860]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others perusing the Monastery: (5)
As of 2014-04-19 19:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (483 votes), past polls