|
# Copyright (C) 1996, 1998 David Muir Sharnoff
|
|
|
|
package File::Flock;
|
|
|
|
require Exporter;
|
|
@ISA = qw(Exporter);
|
|
@EXPORT = qw(lock unlock lock_rename);
|
|
|
|
use Carp;
|
|
use POSIX qw(EAGAIN EACCES EWOULDBLOCK ENOENT EEXIST O_EXCL O_CREAT O_RDWR);
|
|
use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
|
|
use IO::File;
|
|
|
|
use vars qw($VERSION $debug $av0debug);
|
|
|
|
BEGIN {
|
|
$VERSION = 2008.01;
|
|
$debug = 0;
|
|
$av0debug = 0;
|
|
}
|
|
|
|
use strict;
|
|
no strict qw(refs);
|
|
|
|
my %locks; # did we create the file?
|
|
my %lockHandle;
|
|
my %shared;
|
|
my %pid;
|
|
my %rm;
|
|
|
|
sub new
|
|
{
|
|
my ($pkg, $file, $shared, $nonblocking) = @_;
|
|
&lock($file, $shared, $nonblocking) or return undef;
|
|
return bless \$file, $pkg;
|
|
}
|
|
|
|
sub DESTROY
|
|
{
|
|
my ($this) = @_;
|
|
unlock($$this);
|
|
}
|
|
|
|
sub lock
|
|
{
|
|
my ($file, $shared, $nonblocking) = @_;
|
|
|
|
my $f = new IO::File;
|
|
|
|
my $created = 0;
|
|
my $previous = exists $locks{$file};
|
|
|
|
# the file may be springing in and out of existance...
|
|
OPEN:
|
|
for(;;) {
|
|
if (-e $file) {
|
|
unless (sysopen($f, $file, O_RDWR)) {
|
|
redo OPEN if $! == ENOENT;
|
|
croak "open $file: $!";
|
|
}
|
|
} else {
|
|
unless (sysopen($f, $file, O_CREAT|O_EXCL|O_RDWR)) {
|
|
redo OPEN if $! == EEXIST;
|
|
croak "open >$file: $!";
|
|
}
|
|
print STDERR " {$$ " if $debug; # }
|
|
$created = 1;
|
|
}
|
|
last;
|
|
}
|
|
$locks{$file} = $created || $locks{$file} || 0;
|
|
$shared{$file} = $shared;
|
|
$pid{$file} = $$;
|
|
|
|
$lockHandle{$file} = $f;
|
|
|
|
my $flags;
|
|
|
|
$flags = $shared ? LOCK_SH : LOCK_EX;
|
|
$flags |= LOCK_NB
|
|
if $nonblocking;
|
|
|
|
local($0) = "$0 - locking $file" if $av0debug && ! $nonblocking;
|
|
my $r = flock($f, $flags);
|
|
|
|
print STDERR " ($$ " if $debug and $r;
|
|
|
|
if ($r) {
|
|
# let's check to make sure the file wasn't
|
|
# removed on us!
|
|
|
|
my $ifile = (stat($file))[1];
|
|
my $ihandle;
|
|
eval { $ihandle = (stat($f))[1] };
|
|
croak $@ if $@;
|
|
|
|
return 1 if defined $ifile
|
|
and defined $ihandle
|
|
and $ifile == $ihandle;
|
|
|
|
# oh well, try again
|
|
flock($f, LOCK_UN);
|
|
close($f);
|
|
return File::Flock::lock($file);
|
|
}
|
|
|
|
return 1 if $r;
|
|
if ($nonblocking and
|
|
(($! == EAGAIN)
|
|
or ($! == EACCES)
|
|
or ($! == EWOULDBLOCK)))
|
|
{
|
|
if (! $previous) {
|
|
delete $locks{$file};
|
|
delete $lockHandle{$file};
|
|
delete $shared{$file};
|
|
delete $pid{$file};
|
|
}
|
|
if ($created) {
|
|
# oops, a bad thing just happened.
|
|
# We don't want to block, but we made the file.
|
|
&background_remove($f, $file);
|
|
}
|
|
close($f);
|
|
return 0;
|
|
}
|
|
croak "flock $f $flags: $!";
|
|
}
|
|
|
|
#
|
|
# get a lock on a file and remove it if it's empty. This is to
|
|
# remove files that were created just so that they could be locked.
|
|
#
|
|
# To do this without blocking, defer any files that are locked to the
|
|
# the END block.
|
|
#
|
|
sub background_remove
|
|
{
|
|
my ($f, $file) = @_;
|
|
|
|
if (flock($f, LOCK_EX|LOCK_NB)) {
|
|
unlink($file)
|
|
if -s $file == 0;
|
|
flock($f, LOCK_UN);
|
|
return 1;
|
|
} else {
|
|
$rm{$file} = 1
|
|
unless exists $rm{$file};
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
sub unlock
|
|
{
|
|
my ($file) = @_;
|
|
|
|
if (ref $file eq 'File::Flock') {
|
|
bless $file, 'UNIVERSAL'; # avoid destructor later
|
|
$file = $$file;
|
|
}
|
|
|
|
croak "no lock on $file" unless exists $locks{$file};
|
|
my $created = $locks{$file};
|
|
my $unlocked = 0;
|
|
|
|
|
|
my $size = -s $file;
|
|
if ($created && defined($size) && $size == 0) {
|
|
if ($shared{$file}) {
|
|
$unlocked =
|
|
&background_remove($lockHandle{$file}, $file);
|
|
} else {
|
|
# {
|
|
print STDERR " $$} " if $debug;
|
|
unlink($file)
|
|
or croak "unlink $file: $!";
|
|
}
|
|
}
|
|
delete $locks{$file};
|
|
delete $pid{$file};
|
|
|
|
my $f = $lockHandle{$file};
|
|
|
|
delete $lockHandle{$file};
|
|
|
|
return 0 unless defined $f;
|
|
|
|
print STDERR " $$) " if $debug;
|
|
$unlocked or flock($f, LOCK_UN)
|
|
or croak "flock $file UN: $!";
|
|
|
|
close($f);
|
|
return 1;
|
|
}
|
|
|
|
sub lock_rename
|
|
{
|
|
my ($oldfile, $newfile) = @_;
|
|
|
|
if (exists $locks{$newfile}) {
|
|
unlock $newfile;
|
|
}
|
|
delete $locks{$newfile};
|
|
delete $shared{$newfile};
|
|
delete $pid{$newfile};
|
|
delete $lockHandle{$newfile};
|
|
delete $rm{$newfile};
|
|
|
|
$locks{$newfile} = $locks{$oldfile} if exists $locks{$oldfile};
|
|
$shared{$newfile} = $shared{$oldfile} if exists $shared{$oldfile};
|
|
$pid{$newfile} = $pid{$oldfile} if exists $pid{$oldfile};
|
|
$lockHandle{$newfile} = $lockHandle{$oldfile} if exists $lockHandle{$oldfile};
|
|
$rm{$newfile} = $rm{$oldfile} if exists $rm{$oldfile};
|
|
|
|
delete $locks{$oldfile};
|
|
delete $shared{$oldfile};
|
|
delete $pid{$oldfile};
|
|
delete $lockHandle{$oldfile};
|
|
delete $rm{$oldfile};
|
|
}
|
|
|
|
#
|
|
# Unlock any files that are still locked and remove any files
|
|
# that were created just so that they could be locked.
|
|
#
|
|
END {
|
|
my $f;
|
|
for $f (keys %locks) {
|
|
&unlock($f)
|
|
if $pid{$f} == $$;
|
|
}
|
|
|
|
my %bgrm;
|
|
for my $file (keys %rm) {
|
|
my $f = new IO::File;
|
|
if (sysopen($f, $file, O_RDWR)) {
|
|
if (flock($f, LOCK_EX|LOCK_NB)) {
|
|
unlink($file)
|
|
if -s $file == 0;
|
|
flock($f, LOCK_UN);
|
|
} else {
|
|
$bgrm{$file} = 1;
|
|
}
|
|
close($f);
|
|
}
|
|
}
|
|
if (%bgrm) {
|
|
my $ppid = fork;
|
|
croak "cannot fork" unless defined $ppid;
|
|
my $pppid = $$;
|
|
my $b0 = $0;
|
|
$0 = "$b0: waiting for child ($ppid) to fork()";
|
|
unless ($ppid) {
|
|
my $pid = fork;
|
|
croak "cannot fork" unless defined $pid;
|
|
unless ($pid) {
|
|
for my $file (keys %bgrm) {
|
|
my $f = new IO::File;
|
|
if (sysopen($f, $file, O_RDWR)) {
|
|
if (flock($f, LOCK_EX)) {
|
|
unlink($file)
|
|
if -s $file == 0;
|
|
flock($f, LOCK_UN);
|
|
}
|
|
close($f);
|
|
}
|
|
}
|
|
print STDERR " $pppid] $pppid)" if $debug;
|
|
}
|
|
kill(9, $$); # exit w/o END or anything else
|
|
}
|
|
waitpid($ppid, 0);
|
|
kill(9, $$); # exit w/o END or anything else
|
|
}
|
|
}
|
|
|
|
1;
|
|
|
|
__DATA__
|
|
|
|
=head1 NAME
|
|
|
|
File::Flock - file locking with flock
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use File::Flock;
|
|
|
|
lock($filename);
|
|
|
|
lock($filename, 'shared');
|
|
|
|
lock($filename, undef, 'nonblocking');
|
|
|
|
lock($filename, 'shared', 'nonblocking');
|
|
|
|
unlock($filename);
|
|
|
|
my $lock = new File::Flock '/somefile';
|
|
|
|
lock_rename($oldfilename, $newfilename)
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Lock files using the flock() call. If the file to be locked does not
|
|
exist, then the file is created. If the file was created then it will
|
|
be removed when it is unlocked assuming it's still an empty file.
|
|
|
|
Locks can be created by new'ing a B<File::Flock> object. Such locks
|
|
are automatically removed when the object goes out of scope. The
|
|
B<unlock()> method may also be used.
|
|
|
|
B<lock_rename()> is used to tell File::Flock when a file has been
|
|
renamed (and thus the internal locking data that is stored based
|
|
on the filename should be moved to a new name). B<unlock()> the
|
|
new name rather than the original name.
|
|
|
|
=head1 LICENSE
|
|
|
|
File::Flock may be used/modified/distibuted on the same terms
|
|
as perl itself.
|
|
|
|
=head1 AUTHOR
|
|
|
|
David Muir Sharnoff <muir@idiom.org>
|
|
|
|
|