kivitendo/modules/fallback/File/Flock.pm @ 15f021a6
| 23d89499 | Moritz Bunkus | # 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>
|
|||