+++ /dev/null
-# 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>
-
-
projects / kivitendo-erp.git / blobdiff