sourcecode
tilly
<CODE>
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;
</CODE>
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 [id://25065].<P>
The simplest and most common use is:
<CODE>
my $lock = Get Lock(lock_file => "foo.lock");
</CODE>
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.<P>
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.<P>
Oops, a security hole. I made the following rather
important edit:
<CODE>
--- 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)) {
</CODE>
Miscellaneous
Ben Tilly