WebshopApi: Syntax in Tests
[kivitendo-erp.git] / 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