modules/fallback/File/Flock.pm

   1 # Copyright (C) 1996, 1998 David Muir Sharnoff
   2
   3 package File::Flock;
   4
   5 require Exporter;
   6 @ISA = qw(Exporter);
   7 @EXPORT = qw(lock unlock lock_rename);
   8
   9 use Carp;
  10 use POSIX qw(EAGAIN EACCES EWOULDBLOCK ENOENT EEXIST O_EXCL O_CREAT O_RDWR);
  11 use Fcntl qw(LOCK_SH LOCK_EX LOCK_NB LOCK_UN);
  12 use IO::File;
  13
  14 use vars qw($VERSION $debug $av0debug);
  15
  16 BEGIN   {
  17         $VERSION = 2008.01;
  18         $debug = 0;
  19         $av0debug = 0;
  20 }
  21
  22 use strict;
  23 no strict qw(refs);
  24
  25 my %locks;              # did we create the file?
  26 my %lockHandle;
  27 my %shared;
  28 my %pid;
  29 my %rm;
  30
  31 sub new
  32 {
  33         my ($pkg, $file, $shared, $nonblocking) = @_;
  34         &lock($file, $shared, $nonblocking) or return undef;
  35         return bless \$file, $pkg;
  36 }
  37
  38 sub DESTROY
  39 {
  40         my ($this) = @_;
  41         unlock($$this);
  42 }
  43
  44 sub lock
  45 {
  46         my ($file, $shared, $nonblocking) = @_;
  47
  48         my $f = new IO::File;
  49
  50         my $created = 0;
  51         my $previous = exists $locks{$file};
  52
  53         # the file may be springing in and out of existance...
  54         OPEN:
  55         for(;;) {
  56                 if (-e $file) {
  57                         unless (sysopen($f, $file, O_RDWR)) {
  58                                 redo OPEN if $! == ENOENT;
  59                                 croak "open $file: $!";
  60                         }
  61                 } else {
  62                         unless (sysopen($f, $file, O_CREAT|O_EXCL|O_RDWR)) {
  63                                 redo OPEN if $! == EEXIST;
  64                                 croak "open >$file: $!";
  65                         }
  66                         print STDERR " {$$ " if $debug; # }
  67                         $created = 1;
  68                 }
  69                 last;
  70         }
  71         $locks{$file} = $created || $locks{$file} || 0;
  72         $shared{$file} = $shared;
  73         $pid{$file} = $$;
  74
  75         $lockHandle{$file} = $f;
  76
  77         my $flags;
  78
  79         $flags = $shared ? LOCK_SH : LOCK_EX;
  80         $flags |= LOCK_NB
  81                 if $nonblocking;
  82
  83         local($0) = "$0 - locking $file" if $av0debug && ! $nonblocking;
  84         my $r = flock($f, $flags);
  85
  86         print STDERR " ($$ " if $debug and $r;
  87
  88         if ($r) {
  89                 # let's check to make sure the file wasn't
  90                 # removed on us!
  91
  92                 my $ifile = (stat($file))[1];
  93                 my $ihandle;
  94                 eval { $ihandle = (stat($f))[1] };
  95                 croak $@ if $@;
  96
  97                 return 1 if defined $ifile
  98                         and defined $ihandle
  99                         and $ifile == $ihandle;
 100
 101                 # oh well, try again
 102                 flock($f, LOCK_UN);
 103                 close($f);
 104                 return File::Flock::lock($file);
 105         }
 106
 107         return 1 if $r;
 108         if ($nonblocking and
 109                 (($! == EAGAIN)
 110                 or ($! == EACCES)
 111                 or ($! == EWOULDBLOCK)))
 112         {
 113                 if (! $previous) {
 114                         delete $locks{$file};
 115                         delete $lockHandle{$file};
 116                         delete $shared{$file};
 117                         delete $pid{$file};
 118                 }
 119                 if ($created) {
 120                         # oops, a bad thing just happened.
 121                         # We don't want to block, but we made the file.
 122                         &background_remove($f, $file);
 123                 }
 124                 close($f);
 125                 return 0;
 126         }
 127         croak "flock $f $flags: $!";
 128 }
 129
 130 #
 131 # get a lock on a file and remove it if it's empty.  This is to
 132 # remove files that were created just so that they could be locked.
 133 #
 134 # To do this without blocking, defer any files that are locked to the
 135 # the END block.
 136 #
 137 sub background_remove
 138 {
 139         my ($f, $file) = @_;
 140
 141         if (flock($f, LOCK_EX|LOCK_NB)) {
 142                 unlink($file)
 143                         if -s $file == 0;
 144                 flock($f, LOCK_UN);
 145                 return 1;
 146         } else {
 147                 $rm{$file} = 1
 148                         unless exists $rm{$file};
 149                 return 0;
 150         }
 151 }
 152
 153 sub unlock
 154 {
 155         my ($file) = @_;
 156
 157         if (ref $file eq 'File::Flock') {
 158                 bless $file, 'UNIVERSAL'; # avoid destructor later
 159                 $file = $$file;
 160         }
 161
 162         croak "no lock on $file" unless exists $locks{$file};
 163         my $created = $locks{$file};
 164         my $unlocked = 0;
 165
 166
 167         my $size = -s $file;
 168         if ($created && defined($size) && $size == 0) {
 169                 if ($shared{$file}) {
 170                         $unlocked =
 171                                 &background_remove($lockHandle{$file}, $file);
 172                 } else {
 173                         # {
 174                         print STDERR " $$} " if $debug;
 175                         unlink($file)
 176                                 or croak "unlink $file: $!";
 177                 }
 178         }
 179         delete $locks{$file};
 180         delete $pid{$file};
 181
 182         my $f = $lockHandle{$file};
 183
 184         delete $lockHandle{$file};
 185
 186         return 0 unless defined $f;
 187
 188         print STDERR " $$) " if $debug;
 189         $unlocked or flock($f, LOCK_UN)
 190                 or croak "flock $file UN: $!";
 191
 192         close($f);
 193         return 1;
 194 }
 195
 196 sub lock_rename
 197 {
 198         my ($oldfile, $newfile) = @_;
 199
 200         if (exists $locks{$newfile}) {
 201                 unlock $newfile;
 202         }
 203         delete $locks{$newfile};
 204         delete $shared{$newfile};
 205         delete $pid{$newfile};
 206         delete $lockHandle{$newfile};
 207         delete $rm{$newfile};
 208
 209         $locks{$newfile}        = $locks{$oldfile}      if exists $locks{$oldfile};
 210         $shared{$newfile}       = $shared{$oldfile}     if exists $shared{$oldfile};
 211         $pid{$newfile}          = $pid{$oldfile}        if exists $pid{$oldfile};
 212         $lockHandle{$newfile}   = $lockHandle{$oldfile} if exists $lockHandle{$oldfile};
 213         $rm{$newfile}           = $rm{$oldfile}         if exists $rm{$oldfile};
 214
 215         delete $locks{$oldfile};
 216         delete $shared{$oldfile};
 217         delete $pid{$oldfile};
 218         delete $lockHandle{$oldfile};
 219         delete $rm{$oldfile};
 220 }
 221
 222 #
 223 # Unlock any files that are still locked and remove any files
 224 # that were created just so that they could be locked.
 225 #
 226 END {
 227         my $f;
 228         for $f (keys %locks) {
 229                 &unlock($f)
 230                         if $pid{$f} == $$;
 231         }
 232
 233         my %bgrm;
 234         for my $file (keys %rm) {
 235                 my $f = new IO::File;
 236                 if (sysopen($f, $file, O_RDWR)) {
 237                         if (flock($f, LOCK_EX|LOCK_NB)) {
 238                                 unlink($file)
 239                                         if -s $file == 0;
 240                                 flock($f, LOCK_UN);
 241                         } else {
 242                                 $bgrm{$file} = 1;
 243                         }
 244                         close($f);
 245                 }
 246         }
 247         if (%bgrm) {
 248                 my $ppid = fork;
 249                 croak "cannot fork" unless defined $ppid;
 250                 my $pppid = $$;
 251                 my $b0 = $0;
 252                 $0 = "$b0: waiting for child ($ppid) to fork()";
 253                 unless ($ppid) {
 254                         my $pid = fork;
 255                         croak "cannot fork" unless defined $pid;
 256                         unless ($pid) {
 257                                 for my $file (keys %bgrm) {
 258                                         my $f = new IO::File;
 259                                         if (sysopen($f, $file, O_RDWR)) {
 260                                                 if (flock($f, LOCK_EX)) {
 261                                                         unlink($file)
 262                                                                 if -s $file == 0;
 263                                                         flock($f, LOCK_UN);
 264                                                 }
 265                                                 close($f);
 266                                         }
 267                                 }
 268                                 print STDERR " $pppid] $pppid)" if $debug;
 269                         }
 270                         kill(9, $$); # exit w/o END or anything else
 271                 }
 272                 waitpid($ppid, 0);
 273                 kill(9, $$); # exit w/o END or anything else
 274         }
 275 }
 276
 277 1;
 278
 279 __DATA__
 280
 281 =head1 NAME
 282
 283  File::Flock - file locking with flock
 284
 285 =head1 SYNOPSIS
 286
 287  use File::Flock;
 288
 289  lock($filename);
 290
 291  lock($filename, 'shared');
 292
 293  lock($filename, undef, 'nonblocking');
 294
 295  lock($filename, 'shared', 'nonblocking');
 296
 297  unlock($filename);
 298
 299  my $lock = new File::Flock '/somefile';
 300
 301  lock_rename($oldfilename, $newfilename)
 302
 303 =head1 DESCRIPTION
 304
 305 Lock files using the flock() call.  If the file to be locked does not
 306 exist, then the file is created.  If the file was created then it will
 307 be removed when it is unlocked assuming it's still an empty file.
 308
 309 Locks can be created by new'ing a B<File::Flock> object.  Such locks
 310 are automatically removed when the object goes out of scope.  The
 311 B<unlock()> method may also be used.
 312
 313 B<lock_rename()> is used to tell File::Flock when a file has been
 314 renamed (and thus the internal locking data that is stored based
 315 on the filename should be moved to a new name).  B<unlock()> the
 316 new name rather than the original name.
 317
 318 =head1 LICENSE
 319
 320 File::Flock may be used/modified/distibuted on the same terms
 321 as perl itself.
 322
 323 =head1 AUTHOR
 324
 325 David Muir Sharnoff <muir@idiom.org>
 326
 327