Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/LockFile/Simple.pm |
Statements | Executed 18 statements in 2.11ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 588µs | 887µs | BEGIN@72 | LockFile::Simple::
1 | 1 | 1 | 12µs | 14µs | BEGIN@60 | Tapper::Base::
1 | 1 | 1 | 8µs | 63µs | BEGIN@70 | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | _acs_check | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | _acs_lock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | _acs_stale | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | _acs_unlock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | autoclean | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | base | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | configure | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | core_warn | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | delay | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | dir | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | efunc | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | ext | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | format | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | hold | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | lock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | lock_by_file | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | locker | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | lockfile | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | make | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | manager | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | max | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | nfs | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | no_warn | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | release | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | stale | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | take_lock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | trylock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | unlock | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | wafter | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | warn | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | wfunc | LockFile::Simple::
0 | 0 | 0 | 0s | 0s | wmin | LockFile::Simple::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | ;# $Id$ | ||||
2 | ;# | ||||
3 | ;# @COPYRIGHT@ | ||||
4 | ;# | ||||
5 | ;# $Log: Simple.pm,v $ | ||||
6 | ;# Revision 0.4 2007/09/28 19:22:05 jv | ||||
7 | ;# Bump version. | ||||
8 | ;# | ||||
9 | ;# Revision 0.3 2007/09/28 19:19:41 jv | ||||
10 | ;# Revision 0.2.1.5 2000/09/18 19:55:07 ram | ||||
11 | ;# patch5: fixed computation of %F and %D when no '/' in file name | ||||
12 | ;# patch5: fixed OO example of lock to emphasize check on returned value | ||||
13 | ;# patch5: now warns when no lockfile is found during unlocking | ||||
14 | ;# | ||||
15 | ;# Revision 0.2.1.4 2000/08/15 18:41:43 ram | ||||
16 | ;# patch4: updated version number, grrr... | ||||
17 | ;# | ||||
18 | ;# Revision 0.2.1.3 2000/08/15 18:37:37 ram | ||||
19 | ;# patch3: fixed non-working "-wfunc => undef" due to misuse of defined() | ||||
20 | ;# patch3: check for stale lock while we wait for it | ||||
21 | ;# patch3: untaint pid before running kill() for -T scripts | ||||
22 | ;# | ||||
23 | ;# Revision 0.2.1.2 2000/03/02 22:35:02 ram | ||||
24 | ;# patch2: allow "undef" in -efunc and -wfunc to suppress logging | ||||
25 | ;# patch2: documented how to force warn() despite Log::Agent being there | ||||
26 | ;# | ||||
27 | ;# Revision 0.2.1.1 2000/01/04 21:18:10 ram | ||||
28 | ;# patch1: logerr and logwarn are autoloaded, need to check something real | ||||
29 | ;# patch1: forbid re-lock of a file we already locked | ||||
30 | ;# patch1: force $\ to be undef prior to writing the PID to lockfile | ||||
31 | ;# patch1: track where lock was issued in the code | ||||
32 | ;# | ||||
33 | ;# Revision 0.2.1.5 2000/09/18 19:55:07 ram | ||||
34 | ;# patch5: fixed computation of %F and %D when no '/' in file name | ||||
35 | ;# patch5: fixed OO example of lock to emphasize check on returned value | ||||
36 | ;# patch5: now warns when no lockfile is found during unlocking | ||||
37 | ;# | ||||
38 | ;# Revision 0.2.1.4 2000/08/15 18:41:43 ram | ||||
39 | ;# patch4: updated version number, grrr... | ||||
40 | ;# | ||||
41 | ;# Revision 0.2.1.3 2000/08/15 18:37:37 ram | ||||
42 | ;# patch3: fixed non-working "-wfunc => undef" due to misuse of defined() | ||||
43 | ;# patch3: check for stale lock while we wait for it | ||||
44 | ;# patch3: untaint pid before running kill() for -T scripts | ||||
45 | ;# | ||||
46 | ;# Revision 0.2.1.2 2000/03/02 22:35:02 ram | ||||
47 | ;# patch2: allow "undef" in -efunc and -wfunc to suppress logging | ||||
48 | ;# patch2: documented how to force warn() despite Log::Agent being there | ||||
49 | ;# | ||||
50 | ;# Revision 0.2.1.1 2000/01/04 21:18:10 ram | ||||
51 | ;# patch1: logerr and logwarn are autoloaded, need to check something real | ||||
52 | ;# patch1: forbid re-lock of a file we already locked | ||||
53 | ;# patch1: force $\ to be undef prior to writing the PID to lockfile | ||||
54 | ;# patch1: track where lock was issued in the code | ||||
55 | ;# | ||||
56 | ;# Revision 0.2 1999/12/07 20:51:05 ram | ||||
57 | ;# Baseline for 0.2 release. | ||||
58 | ;# | ||||
59 | |||||
60 | 3 | 36µs | 2 | 17µs | # spent 14µs (12+2) within Tapper::Base::BEGIN@60 which was called:
# once (12µs+2µs) by Tapper::Base::BEGIN@12 at line 60 # spent 14µs making 1 call to Tapper::Base::BEGIN@60
# spent 2µs making 1 call to strict::import |
61 | |||||
62 | ######################################################################## | ||||
63 | package LockFile::Simple; | ||||
64 | |||||
65 | # | ||||
66 | # This package extracts the simple locking logic used by mailagent-3.0 | ||||
67 | # into a standalone Perl module to be reused in other applications. | ||||
68 | # | ||||
69 | |||||
70 | 3 | 20µs | 2 | 118µs | # spent 63µs (8+55) within LockFile::Simple::BEGIN@70 which was called:
# once (8µs+55µs) by Tapper::Base::BEGIN@12 at line 70 # spent 63µs making 1 call to LockFile::Simple::BEGIN@70
# spent 55µs making 1 call to vars::import |
71 | |||||
72 | 3 | 1.94ms | 2 | 913µs | # spent 887µs (588+298) within LockFile::Simple::BEGIN@72 which was called:
# once (588µs+298µs) by Tapper::Base::BEGIN@12 at line 72 # spent 887µs making 1 call to LockFile::Simple::BEGIN@72
# spent 26µs making 1 call to Exporter::import |
73 | 1 | 1µs | require Exporter; | ||
74 | 1 | 84µs | require LockFile::Lock::Simple; | ||
75 | 1 | 23µs | eval "use Log::Agent"; # spent 46µs executing statements in string eval # includes 35µs spent executing 1 call to 1 sub defined therein. | ||
76 | |||||
77 | 1 | 7µs | @ISA = qw(Exporter); | ||
78 | 1 | 400ns | @EXPORT = (); | ||
79 | 1 | 1µs | @EXPORT_OK = qw(lock trylock unlock); | ||
80 | 1 | 400ns | $VERSION = '0.207'; | ||
81 | |||||
82 | 1 | 400ns | my $LOCKER = undef; # Default locking object | ||
83 | |||||
84 | # | ||||
85 | # ->make | ||||
86 | # | ||||
87 | # Create a file locking object, responsible for holding the locking | ||||
88 | # parameters to be used by all the subsequent locks requested from | ||||
89 | # this locking object. | ||||
90 | # | ||||
91 | # Configuration attributes: | ||||
92 | # | ||||
93 | # autoclean keep track of locks and release pending one at END time | ||||
94 | # max max number of attempts | ||||
95 | # delay seconds to wait between attempts | ||||
96 | # format how to derive lockfile from file to be locked | ||||
97 | # hold max amount of seconds before breaking lock (0 for never) | ||||
98 | # ext lock extension | ||||
99 | # nfs true if lock must "work" on top of NFS | ||||
100 | # stale try to detect stale locks via SIGZERO and delete them | ||||
101 | # warn flag to turn warnings on | ||||
102 | # wmin warn once after that many waiting seconds | ||||
103 | # wafter warn every that many seconds after first warning | ||||
104 | # wfunc warning function to be called | ||||
105 | # efunc error function to be called | ||||
106 | # | ||||
107 | # Additional attributes: | ||||
108 | # | ||||
109 | # manager lock manager, used when autoclean | ||||
110 | # lock_by_file returns lock by filename | ||||
111 | # | ||||
112 | # The creation routine first and sole argument is a "hash table list" listing | ||||
113 | # all the configuration attributes. Missing attributes are given a default | ||||
114 | # value. A call to ->configure can alter the configuration parameters of | ||||
115 | # an existing object. | ||||
116 | # | ||||
117 | sub make { | ||||
118 | my $self = bless {}, shift; | ||||
119 | my (@hlist) = @_; | ||||
120 | |||||
121 | # Set configuration defaults, then override with user preferences | ||||
122 | $self->{'max'} = 30; | ||||
123 | $self->{'delay'} = 2; | ||||
124 | $self->{'hold'} = 3600; | ||||
125 | $self->{'ext'} = '.lock'; | ||||
126 | $self->{'nfs'} = 0; | ||||
127 | $self->{'stale'} = 0; | ||||
128 | $self->{'warn'} = 1; | ||||
129 | $self->{'wmin'} = 15; | ||||
130 | $self->{'wafter'} = 20; | ||||
131 | $self->{'autoclean'} = 0; | ||||
132 | $self->{'lock_by_file'} = {}; | ||||
133 | |||||
134 | # The logxxx routines are autoloaded, so need to check for @EXPORT | ||||
135 | $self->{'wfunc'} = defined(@Log::Agent::EXPORT) ? \&logwarn : \&core_warn; | ||||
136 | $self->{'efunc'} = defined(@Log::Agent::EXPORT) ? \&logerr : \&core_warn; | ||||
137 | |||||
138 | $self->configure(@hlist); # Will init "manager" if necessary | ||||
139 | return $self; | ||||
140 | } | ||||
141 | |||||
142 | # | ||||
143 | # ->locker -- "once" function | ||||
144 | # | ||||
145 | # Compute the default locking object. | ||||
146 | # | ||||
147 | sub locker { | ||||
148 | return $LOCKER || ($LOCKER = LockFile::Simple->make('-warn' => 1)); | ||||
149 | } | ||||
150 | |||||
151 | # | ||||
152 | # ->configure | ||||
153 | # | ||||
154 | # Extract known configuration parameters from the specified hash list | ||||
155 | # and use their values to change the object's corresponding parameters. | ||||
156 | # | ||||
157 | # Parameters are specified as (-warn => 1, -ext => '.lock') for instance. | ||||
158 | # | ||||
159 | sub configure { | ||||
160 | my $self = shift; | ||||
161 | my (%hlist) = @_; | ||||
162 | my @known = qw( | ||||
163 | autoclean | ||||
164 | max delay hold format ext nfs warn wfunc wmin wafter efunc stale | ||||
165 | ); | ||||
166 | |||||
167 | foreach my $attr (@known) { | ||||
168 | $self->{$attr} = $hlist{"-$attr"} if exists $hlist{"-$attr"}; | ||||
169 | } | ||||
170 | |||||
171 | $self->{'wfunc'} = \&no_warn unless defined $self->{'wfunc'}; | ||||
172 | $self->{'efunc'} = \&no_warn unless defined $self->{'efunc'}; | ||||
173 | |||||
174 | if ($self->autoclean) { | ||||
175 | require LockFile::Manager; | ||||
176 | # Created via "once" function | ||||
177 | $self->{'manager'} = LockFile::Manager->manager( | ||||
178 | $self->wfunc, $self->efunc); | ||||
179 | } | ||||
180 | } | ||||
181 | |||||
182 | # | ||||
183 | # Attribute access | ||||
184 | # | ||||
185 | |||||
186 | sub max { $_[0]->{'max'} } | ||||
187 | sub delay { $_[0]->{'delay'} } | ||||
188 | sub format { $_[0]->{'format'} } | ||||
189 | sub hold { $_[0]->{'hold'} } | ||||
190 | sub nfs { $_[0]->{'nfs'} } | ||||
191 | sub stale { $_[0]->{'stale'} } | ||||
192 | sub ext { $_[0]->{'ext'} } | ||||
193 | sub warn { $_[0]->{'warn'} } | ||||
194 | sub wmin { $_[0]->{'wmin'} } | ||||
195 | sub wafter { $_[0]->{'wafter'} } | ||||
196 | sub wfunc { $_[0]->{'wfunc'} } | ||||
197 | sub efunc { $_[0]->{'efunc'} } | ||||
198 | sub autoclean { $_[0]->{'autoclean'} } | ||||
199 | sub lock_by_file { $_[0]->{'lock_by_file'} } | ||||
200 | sub manager { $_[0]->{'manager'} } | ||||
201 | |||||
202 | # | ||||
203 | # Warning and error reporting -- Log::Agent used only when available | ||||
204 | # | ||||
205 | |||||
206 | sub core_warn { CORE::warn(@_) } | ||||
207 | sub no_warn { return } | ||||
208 | |||||
209 | # | ||||
210 | # ->lock | ||||
211 | # | ||||
212 | # Lock specified file, possibly using alternate file "format". | ||||
213 | # Returns whether file was locked or not at the end of the configured | ||||
214 | # blocking period by providing the LockFile::Lock instance if successful. | ||||
215 | # | ||||
216 | # For quick and dirty scripts wishing to use locks, create the locking | ||||
217 | # object if not invoked as a method, turning on warnings. | ||||
218 | # | ||||
219 | sub lock { | ||||
220 | my $self = shift; | ||||
221 | unless (ref $self) { # Not invoked as a method | ||||
222 | unshift(@_, $self); | ||||
223 | $self = locker(); | ||||
224 | } | ||||
225 | my ($file, $format) = @_; # File to be locked, lock format | ||||
226 | return $self->take_lock($file, $format, 0); | ||||
227 | } | ||||
228 | |||||
229 | # | ||||
230 | # ->trylock | ||||
231 | # | ||||
232 | # Attempt to lock specified file, possibly using alternate file "format". | ||||
233 | # If the file is already locked, don't block and return undef. The | ||||
234 | # LockFile::Lock instance is returned upon success. | ||||
235 | # | ||||
236 | # For quick and dirty scripts wishing to use locks, create the locking | ||||
237 | # object if not invoked as a method, turning on warnings. | ||||
238 | # | ||||
239 | sub trylock { | ||||
240 | my $self = shift; | ||||
241 | unless (ref $self) { # Not invoked as a method | ||||
242 | unshift(@_, $self); | ||||
243 | $self = locker(); | ||||
244 | } | ||||
245 | my ($file, $format) = @_; # File to be locked, lock format | ||||
246 | return $self->take_lock($file, $format, 1); | ||||
247 | } | ||||
248 | |||||
249 | # | ||||
250 | # ->take_lock | ||||
251 | # | ||||
252 | # Common code for ->lock and ->trylock. | ||||
253 | # Returns a LockFile::Lock object on success, undef on failure. | ||||
254 | # | ||||
255 | sub take_lock { | ||||
256 | my $self = shift; | ||||
257 | my ($file, $format, $tryonly) = @_; | ||||
258 | |||||
259 | # | ||||
260 | # If lock was already taken by us, it's an error when $tryonly is 0. | ||||
261 | # Otherwise, simply fail to get the lock. | ||||
262 | # | ||||
263 | |||||
264 | my $lock = $self->lock_by_file->{$file}; | ||||
265 | if (defined $lock) { | ||||
266 | my $where = $lock->where; | ||||
267 | &{$self->efunc}("file $file already locked at $where") unless $tryonly; | ||||
268 | return undef; | ||||
269 | } | ||||
270 | |||||
271 | my $locked = $self->_acs_lock($file, $format, $tryonly); | ||||
272 | return undef unless $locked; | ||||
273 | |||||
274 | # | ||||
275 | # Create LockFile::Lock object | ||||
276 | # | ||||
277 | |||||
278 | my ($package, $filename, $line) = caller(1); | ||||
279 | $lock = LockFile::Lock::Simple->make($self, $file, $format, | ||||
280 | $filename, $line); | ||||
281 | $self->manager->remember($lock) if $self->autoclean; | ||||
282 | $self->lock_by_file->{$file} = $lock; | ||||
283 | |||||
284 | return $lock; | ||||
285 | } | ||||
286 | |||||
287 | # | ||||
288 | # ->unlock | ||||
289 | # | ||||
290 | # Unlock file. | ||||
291 | # Returns true if file was unlocked. | ||||
292 | # | ||||
293 | sub unlock { | ||||
294 | my $self = shift; | ||||
295 | unless (ref $self) { # Not invoked as a method | ||||
296 | unshift(@_, $self); | ||||
297 | $self = locker(); | ||||
298 | } | ||||
299 | my ($file, $format) = @_; # File to be unlocked, lock format | ||||
300 | |||||
301 | if (defined $format) { | ||||
302 | require Carp; | ||||
303 | Carp::carp("2nd argument (format) is no longer needed nor used"); | ||||
304 | } | ||||
305 | |||||
306 | # | ||||
307 | # Retrieve LockFile::Lock object | ||||
308 | # | ||||
309 | |||||
310 | my $lock = $self->lock_by_file->{$file}; | ||||
311 | |||||
312 | unless (defined $lock) { | ||||
313 | &{$self->efunc}("file $file not currently locked"); | ||||
314 | return undef; | ||||
315 | } | ||||
316 | |||||
317 | return $self->release($lock); | ||||
318 | } | ||||
319 | |||||
320 | # | ||||
321 | # ->release -- not exported (i.e. not documented) | ||||
322 | # | ||||
323 | # Same a unlock, but we're passed a LockFile::Lock object. | ||||
324 | # And we MUST be called as a method (usually via LockFile::Lock, not user code). | ||||
325 | # | ||||
326 | # Returns true if file was unlocked. | ||||
327 | # | ||||
328 | sub release { | ||||
329 | my $self = shift; | ||||
330 | my ($lock) = @_; | ||||
331 | my $file = $lock->file; | ||||
332 | my $format = $lock->format; | ||||
333 | $self->manager->forget($lock) if $self->autoclean; | ||||
334 | delete $self->lock_by_file->{$file}; | ||||
335 | return $self->_acs_unlock($file, $format); | ||||
336 | } | ||||
337 | |||||
338 | # | ||||
339 | # ->lockfile | ||||
340 | # | ||||
341 | # Return the name of the lockfile, given the file name to lock and the custom | ||||
342 | # string provided by the user. The following macros are substituted: | ||||
343 | # %D: the file dir name | ||||
344 | # %f: the file name (full path) | ||||
345 | # %F: the file base name (last path component) | ||||
346 | # %p: the process's pid | ||||
347 | # %%: a plain % character | ||||
348 | # | ||||
349 | sub lockfile { | ||||
350 | my $self = shift; | ||||
351 | my ($file, $format) = @_; | ||||
352 | local $_ = defined($format) ? $format : $self->format; | ||||
353 | s/%%/\01/g; # Protect double percent signs | ||||
354 | s/%/\02/g; # Protect against substitutions adding their own % | ||||
355 | s/\02f/$file/g; # %f is the full path name | ||||
356 | s/\02D/&dir($file)/ge; # %D is the dir name | ||||
357 | s/\02F/&base($file)/ge; # %F is the base name | ||||
358 | s/\02p/$$/g; # %p is the process's pid | ||||
359 | s/\02/%/g; # All other % kept as-is | ||||
360 | s/\01/%/g; # Restore escaped % signs | ||||
361 | $_; | ||||
362 | } | ||||
363 | |||||
364 | # Return file basename (last path component) | ||||
365 | sub base { | ||||
366 | my ($file) = @_; | ||||
367 | my ($base) = $file =~ m|^.*/(.*)|; | ||||
368 | return ($base eq '') ? $file : $base; | ||||
369 | } | ||||
370 | |||||
371 | # Return dirname | ||||
372 | sub dir { | ||||
373 | my ($file) = @_; | ||||
374 | my ($dir) = $file =~ m|^(.*)/.*|; | ||||
375 | return ($dir eq '') ? '.' : $dir; | ||||
376 | } | ||||
377 | |||||
378 | # | ||||
379 | # _acs_lock -- private | ||||
380 | # | ||||
381 | # Internal locking routine. | ||||
382 | # | ||||
383 | # If $try is true, don't wait if the file is already locked. | ||||
384 | # Returns true if the file was locked. | ||||
385 | # | ||||
386 | sub _acs_lock { ## private | ||||
387 | my $self = shift; | ||||
388 | my ($file, $format, $try) = @_; | ||||
389 | my $max = $self->max; | ||||
390 | my $delay = $self->delay; | ||||
391 | my $stamp = $$; | ||||
392 | |||||
393 | # For NFS, we need something more unique than the process's PID | ||||
394 | $stamp .= ':' . hostname if $self->nfs; | ||||
395 | |||||
396 | # Compute locking file name -- hardwired default format is "%f.lock" | ||||
397 | my $lockfile = $file . $self->ext; | ||||
398 | $format = $self->format unless defined $format; | ||||
399 | $lockfile = $self->lockfile($file, $format) if defined $format; | ||||
400 | |||||
401 | # Detect stale locks or break lock if held for too long | ||||
402 | $self->_acs_stale($file, $lockfile) if $self->stale; | ||||
403 | $self->_acs_check($file, $lockfile) if $self->hold; | ||||
404 | |||||
405 | my $waited = 0; # Amount of time spent sleeping | ||||
406 | my $lastwarn = 0; # Last time we warned them... | ||||
407 | my $warn = $self->warn; | ||||
408 | my ($wmin, $wafter, $wfunc); | ||||
409 | ($wmin, $wafter, $wfunc) = | ||||
410 | ($self->wmin, $self->wafter, $self->wfunc) if $warn; | ||||
411 | my $locked = 0; | ||||
412 | my $mask = umask(0333); # No write permission | ||||
413 | local *FILE; | ||||
414 | |||||
415 | while ($max-- > 0) { | ||||
416 | if (-f $lockfile) { | ||||
417 | next unless $try; | ||||
418 | umask($mask); | ||||
419 | return 0; # Already locked | ||||
420 | } | ||||
421 | |||||
422 | # Attempt to create lock | ||||
423 | if (open(FILE, ">$lockfile")) { | ||||
424 | local $\ = undef; | ||||
425 | print FILE "$stamp\n"; | ||||
426 | close FILE; | ||||
427 | open(FILE, $lockfile); # Check lock | ||||
428 | my $l; | ||||
429 | chop($l = <FILE>); | ||||
430 | $locked = $l eq $stamp; | ||||
431 | $l = <FILE>; # Must be EOF | ||||
432 | $locked = 0 if defined $l; | ||||
433 | close FILE; | ||||
434 | last if $locked; # Lock seems to be ours | ||||
435 | } elsif ($try) { | ||||
436 | umask($mask); | ||||
437 | return 0; # Already locked, or cannot create lock | ||||
438 | } | ||||
439 | } continue { | ||||
440 | sleep($delay); # Busy: wait | ||||
441 | $waited += $delay; | ||||
442 | |||||
443 | # Warn them once after $wmin seconds and then every $wafter seconds | ||||
444 | if ( | ||||
445 | $warn && | ||||
446 | ((!$lastwarn && $waited > $wmin) || | ||||
447 | ($waited - $lastwarn) > $wafter) | ||||
448 | ) { | ||||
449 | my $waiting = $lastwarn ? 'still waiting' : 'waiting'; | ||||
450 | my $after = $lastwarn ? 'after' : 'since'; | ||||
451 | my $s = $waited == 1 ? '' : 's'; | ||||
452 | &$wfunc("$waiting for $file lock $after $waited second$s"); | ||||
453 | $lastwarn = $waited; | ||||
454 | } | ||||
455 | |||||
456 | # While we wait, existing lockfile may become stale or too old | ||||
457 | $self->_acs_stale($file, $lockfile) if $self->stale; | ||||
458 | $self->_acs_check($file, $lockfile) if $self->hold; | ||||
459 | } | ||||
460 | |||||
461 | umask($mask); | ||||
462 | return $locked; | ||||
463 | } | ||||
464 | |||||
465 | # | ||||
466 | # ->_acs_unlock -- private | ||||
467 | # | ||||
468 | # Unlock file. If lock format is specified, it must match the one used | ||||
469 | # at lock time. | ||||
470 | # | ||||
471 | # Return true if file was indeed locked by us and is now properly unlocked. | ||||
472 | # | ||||
473 | sub _acs_unlock { ## private | ||||
474 | my $self = shift; | ||||
475 | my ($file, $format) = @_; # Locked file, locking format | ||||
476 | my $stamp = $$; | ||||
477 | $stamp .= ':' . hostname if $self->nfs; | ||||
478 | |||||
479 | # Compute locking file name -- hardwired default format is "%f.lock" | ||||
480 | my $lockfile = $file . $self->ext; | ||||
481 | $format = $self->format unless defined $format; | ||||
482 | $lockfile = $self->lockfile($file, $format) if defined $format; | ||||
483 | |||||
484 | local *FILE; | ||||
485 | my $unlocked = 0; | ||||
486 | |||||
487 | if (-f $lockfile) { | ||||
488 | open(FILE, $lockfile); | ||||
489 | my $l; | ||||
490 | chop($l = <FILE>); | ||||
491 | close FILE; | ||||
492 | if ($l eq $stamp) { # Pid (plus hostname possibly) is OK | ||||
493 | $unlocked = 1; | ||||
494 | unless (unlink $lockfile) { | ||||
495 | $unlocked = 0; | ||||
496 | &{$self->efunc}("cannot unlock $file: $!"); | ||||
497 | } | ||||
498 | } else { | ||||
499 | &{$self->efunc}("cannot unlock $file: lock not owned"); | ||||
500 | } | ||||
501 | } else { | ||||
502 | &{$self->wfunc}("no lockfile found for $file"); | ||||
503 | } | ||||
504 | |||||
505 | return $unlocked; # Did we successfully unlock? | ||||
506 | } | ||||
507 | |||||
508 | # | ||||
509 | # ->_acs_check | ||||
510 | # | ||||
511 | # Make sure lock lasts only for a reasonable time. If it has expired, | ||||
512 | # then remove the lockfile. | ||||
513 | # | ||||
514 | # This is not enabled by default because there is a race condition between | ||||
515 | # the time we stat the file and the time we unlink the lockfile. | ||||
516 | # | ||||
517 | sub _acs_check { | ||||
518 | my $self = shift; | ||||
519 | my ($file, $lockfile) = @_; | ||||
520 | |||||
521 | my $mtime = (stat($lockfile))[9]; | ||||
522 | return unless defined $mtime; # Assume file does not exist | ||||
523 | my $hold = $self->hold; | ||||
524 | |||||
525 | # If file too old to be considered stale? | ||||
526 | if ((time - $mtime) > $hold) { | ||||
527 | |||||
528 | # RACE CONDITION -- shall we lock the lockfile? | ||||
529 | |||||
530 | unless (unlink $lockfile) { | ||||
531 | &{$self->efunc}("cannot unlink $lockfile: $!"); | ||||
532 | return; | ||||
533 | } | ||||
534 | |||||
535 | if ($self->warn) { | ||||
536 | my $s = $hold == 1 ? '' : 's'; | ||||
537 | &{$self->wfunc}("UNLOCKED $file (lock older than $hold second$s)"); | ||||
538 | } | ||||
539 | } | ||||
540 | } | ||||
541 | |||||
542 | # | ||||
543 | # ->_acs_stale | ||||
544 | # | ||||
545 | # Detect stale locks and remove them. This works by sending a SIGZERO to | ||||
546 | # the pid held in the lockfile. If configured for NFS, only processes | ||||
547 | # on the same host than the one holding the lock will be able to perform | ||||
548 | # the check. | ||||
549 | # | ||||
550 | # Stale lock detection is not enabled by default because there is a race | ||||
551 | # condition between the time we check for the pid, and the time we unlink | ||||
552 | # the lockfile: we could well be unlinking a new lockfile created inbetween. | ||||
553 | # | ||||
554 | sub _acs_stale { | ||||
555 | my $self = shift; | ||||
556 | my ($file, $lockfile) = @_; | ||||
557 | |||||
558 | local *FILE; | ||||
559 | open(FILE, $lockfile) || return; | ||||
560 | my $stamp; | ||||
561 | chop($stamp = <FILE>); | ||||
562 | close FILE; | ||||
563 | |||||
564 | my ($pid, $hostname); | ||||
565 | |||||
566 | if ($self->nfs) { | ||||
567 | ($pid, $hostname) = $stamp =~ /^(\d+):(\S+)/; | ||||
568 | my $local = hostname; | ||||
569 | return if $local ne $hostname; | ||||
570 | return if kill 0, $pid; | ||||
571 | $hostname = " on $hostname"; | ||||
572 | } else { | ||||
573 | ($pid) = $stamp =~ /^(\d+)$/; # Untaint $pid for kill() | ||||
574 | $hostname = ''; | ||||
575 | return if kill 0, $pid; | ||||
576 | } | ||||
577 | |||||
578 | # RACE CONDITION -- shall we lock the lockfile? | ||||
579 | |||||
580 | unless (unlink $lockfile) { | ||||
581 | &{$self->efunc}("cannot unlink stale $lockfile: $!"); | ||||
582 | return; | ||||
583 | } | ||||
584 | |||||
585 | &{$self->wfunc}("UNLOCKED $file (stale lock by PID $pid$hostname)"); | ||||
586 | } | ||||
587 | |||||
588 | 1 | 5µs | 1; | ||
589 | |||||
590 | ######################################################################## | ||||
591 | |||||
592 | =head1 NAME | ||||
593 | |||||
594 | LockFile::Simple - simple file locking scheme | ||||
595 | |||||
596 | =head1 SYNOPSIS | ||||
597 | |||||
598 | use LockFile::Simple qw(lock trylock unlock); | ||||
599 | |||||
600 | # Simple locking using default settings | ||||
601 | lock("/some/file") || die "can't lock /some/file\n"; | ||||
602 | warn "already locked\n" unless trylock("/some/file"); | ||||
603 | unlock("/some/file"); | ||||
604 | |||||
605 | # Build customized locking manager object | ||||
606 | $lockmgr = LockFile::Simple->make(-format => '%f.lck', | ||||
607 | -max => 20, -delay => 1, -nfs => 1); | ||||
608 | |||||
609 | $lockmgr->lock("/some/file") || die "can't lock /some/file\n"; | ||||
610 | $lockmgr->trylock("/some/file"); | ||||
611 | $lockmgr->unlock("/some/file"); | ||||
612 | |||||
613 | $lockmgr->configure(-nfs => 0); | ||||
614 | |||||
615 | # Using lock handles | ||||
616 | my $lock = $lockmgr->lock("/some/file"); | ||||
617 | $lock->release; | ||||
618 | |||||
619 | =head1 DESCRIPTION | ||||
620 | |||||
621 | This simple locking scheme is not based on any file locking system calls | ||||
622 | such as C<flock()> or C<lockf()> but rather relies on basic file system | ||||
623 | primitives and properties, such as the atomicity of the C<write()> system | ||||
624 | call. It is not meant to be exempt from all race conditions, especially over | ||||
625 | NFS. The algorithm used is described below in the B<ALGORITHM> section. | ||||
626 | |||||
627 | It is possible to customize the locking operations to attempt locking | ||||
628 | once every 5 seconds for 30 times, or delete stale locks (files that are | ||||
629 | deemed too ancient) before attempting the locking. | ||||
630 | |||||
631 | =head1 ALGORITHM | ||||
632 | |||||
633 | The locking alogrithm attempts to create a I<lockfile> using a temporarily | ||||
634 | redefined I<umask> (leaving only read rights to prevent further create | ||||
635 | operations). It then writes the process ID (PID) of the process and closes | ||||
636 | the file. That file is then re-opened and read. If we are able to read the | ||||
637 | same PID we wrote, and only that, we assume the locking is successful. | ||||
638 | |||||
639 | When locking over NFS, i.e. when the one of the potentially locking processes | ||||
640 | could access the I<lockfile> via NFS, then writing the PID is not enough. | ||||
641 | We also write the hostname where locking is attempted to ensure the data | ||||
642 | are unique. | ||||
643 | |||||
644 | =head1 CUSTOMIZING | ||||
645 | |||||
646 | Customization is only possible by using the object-oriented interface, | ||||
647 | since the configuration parameters are stored within the object. The | ||||
648 | object creation routine C<make> can be given configuration parmeters in | ||||
649 | the form a "hash table list", i.e. a list of key/value pairs. Those | ||||
650 | parameters can later be changed via C<configure> by specifying a similar | ||||
651 | list of key/value pairs. | ||||
652 | |||||
653 | To benefit from the bareword quoting Perl offers, all the parameters must | ||||
654 | be prefixed with the C<-> (minus) sign, as in C<-format> for the I<format> | ||||
655 | parameter.. However, when querying the object, the minus must be omitted, | ||||
656 | as in C<$obj-E<gt>format>. | ||||
657 | |||||
658 | Here are the available configuration parmeters along with their meaning, | ||||
659 | listed in alphabetical order: | ||||
660 | |||||
661 | =over 4 | ||||
662 | |||||
663 | =item I<autoclean> | ||||
664 | |||||
665 | When true, all locks are remembered and pending ones are automatically | ||||
666 | released when the process exits normally (i.e. whenever Perl calls the | ||||
667 | END routines). | ||||
668 | |||||
669 | =item I<delay> | ||||
670 | |||||
671 | The amount of seconds to wait between locking attempts when the file appears | ||||
672 | to be already locked. Default is 2 seconds. | ||||
673 | |||||
674 | =item I<efunc> | ||||
675 | |||||
676 | A function pointer to dereference when an error is to be reported. By default, | ||||
677 | it redirects to the logerr() routine if you have Log::Agent installed, | ||||
678 | to Perl's warn() function otherwise. | ||||
679 | |||||
680 | You may set it explicitely to C<\&LockFile::Simple::core_warn> to force the | ||||
681 | use of Perl's warn() function, or to C<undef> to suppress logging. | ||||
682 | |||||
683 | =item I<ext> | ||||
684 | |||||
685 | The locking extension that must be added to the file path to be locked to | ||||
686 | compute the I<lockfile> path. Default is C<.lock> (note that C<.> is part | ||||
687 | of the extension and can therefore be changed). Ignored when I<format> is | ||||
688 | also used. | ||||
689 | |||||
690 | =item I<format> | ||||
691 | |||||
692 | Using this parmeter supersedes the I<ext> parmeter. The formatting string | ||||
693 | specified is run through a rudimentary macro expansion to derive the | ||||
694 | I<lockfile> path from the file to be locked. The following macros are | ||||
695 | available: | ||||
696 | |||||
697 | %% A real % sign | ||||
698 | %f The full file path name | ||||
699 | %D The directory where the file resides | ||||
700 | %F The base name of the file | ||||
701 | %p The process ID (PID) | ||||
702 | |||||
703 | The default is to use the locking extension, which itself is C<.lock>, so | ||||
704 | it is as if the format used was C<%f.lock>, but one could imagine things | ||||
705 | like C</var/run/%F.%p>, i.e. the I<lockfile> does not necessarily lie besides | ||||
706 | the locked file (which could even be missing). | ||||
707 | |||||
708 | When locking, the locking format can be specified to supersede the object | ||||
709 | configuration itself. | ||||
710 | |||||
711 | =item I<hold> | ||||
712 | |||||
713 | Maximum amount of seconds we may hold a lock. Past that amount of time, | ||||
714 | an existing I<lockfile> is removed, being taken for a stale lock. Default | ||||
715 | is 3600 seconds. Specifying 0 prevents any forced unlocking. | ||||
716 | |||||
717 | =item I<max> | ||||
718 | |||||
719 | Amount of times we retry locking when the file is busy, sleeping I<delay> | ||||
720 | seconds between attempts. Defaults to 30. | ||||
721 | |||||
722 | =item I<nfs> | ||||
723 | |||||
724 | A boolean flag, false by default. Setting it to true means we could lock | ||||
725 | over NFS and therefore the hostname must be included along with the process | ||||
726 | ID in the stamp written to the lockfile. | ||||
727 | |||||
728 | =item I<stale> | ||||
729 | |||||
730 | A boolean flag, false by default. When set to true, we attempt to detect | ||||
731 | stale locks and break them if necessary. | ||||
732 | |||||
733 | =item I<wafter> | ||||
734 | |||||
735 | Stands for I<warn after>. It is the number of seconds past the first | ||||
736 | warning during locking time after which a new warning should be emitted. | ||||
737 | See I<warn> and I<wmin> below. Default is 20. | ||||
738 | |||||
739 | =item I<warn> | ||||
740 | |||||
741 | A boolean flag, true by default. To suppress any warning, set it to false. | ||||
742 | |||||
743 | =item I<wfunc> | ||||
744 | |||||
745 | A function pointer to dereference when a warning is to be issued. By default, | ||||
746 | it redirects to the logwarn() routine if you have Log::Agent installed, | ||||
747 | to Perl's warn() function otherwise. | ||||
748 | |||||
749 | You may set it explicitely to C<\&LockFile::Simple::core_warn> to force the | ||||
750 | use of Perl's warn() function, or to C<undef> to suppress logging. | ||||
751 | |||||
752 | =item I<wmin> | ||||
753 | |||||
754 | The minimal amount of time when waiting for a lock after which a first | ||||
755 | warning must be emitted, if I<warn> is true. After that, a warning will | ||||
756 | be emitted every I<wafter> seconds. Defaults to 15. | ||||
757 | |||||
758 | =back | ||||
759 | |||||
760 | Each of those configuration attributes can be queried on the object directly: | ||||
761 | |||||
762 | $obj = LockFile::Simple->make(-nfs => 1); | ||||
763 | $on_nfs = $obj->nfs; | ||||
764 | |||||
765 | Those are pure query routines, i.e. you cannot say: | ||||
766 | |||||
767 | $obj->nfs(0); # WRONG | ||||
768 | $obj->configure(-nfs => 0); # Right | ||||
769 | |||||
770 | to turn of the NFS attribute. That is because my OO background chokes | ||||
771 | at having querying functions with side effects. | ||||
772 | |||||
773 | =head1 INTERFACE | ||||
774 | |||||
775 | The OO interface documented below specifies the signature and the | ||||
776 | semantics of the operations. Only the C<lock>, C<trylock> and | ||||
777 | C<unlock> operation can be imported and used via a non-OO interface, | ||||
778 | with the exact same signature nonetheless. | ||||
779 | |||||
780 | The interface contains all the attribute querying routines, one for | ||||
781 | each configuration parmeter documented in the B<CUSTOMIZING> section | ||||
782 | above, plus, in alphabetical order: | ||||
783 | |||||
784 | =over 4 | ||||
785 | |||||
786 | =item configure(I<-key =E<gt> value, -key2 =E<gt> value2, ...>) | ||||
787 | |||||
788 | Change the specified configuration parameters and silently ignore | ||||
789 | the invalid ones. | ||||
790 | |||||
791 | =item lock(I<file>, I<format>) | ||||
792 | |||||
793 | Attempt to lock the file, using the optional locking I<format> if | ||||
794 | specified, otherwise using the default I<format> scheme configured | ||||
795 | in the object, or by simply appending the I<ext> extension to the file. | ||||
796 | |||||
797 | If the file is already locked, sleep I<delay> seconds before retrying, | ||||
798 | repeating try/sleep at most I<max> times. If warning is configured, | ||||
799 | a first warning is emitted after waiting for I<wmin> seconds, and | ||||
800 | then once every I<wafter> seconds, via the I<wfunc> routine. | ||||
801 | |||||
802 | Before the first attempt, and if I<hold> is non-zero, any existing | ||||
803 | I<lockfile> is checked for being too old, and it is removed if found | ||||
804 | to be stale. A warning is emitted via the I<wfunc> routine in that | ||||
805 | case, if allowed. | ||||
806 | |||||
807 | Likewise, if I<stale> is non-zero, a check is made to see whether | ||||
808 | any locking process is still around (only if the lock holder is on the | ||||
809 | same machine when NFS locking is configured). Should the locking | ||||
810 | process be dead, the I<lockfile> is declared stale and removed. | ||||
811 | |||||
812 | Returns a lock handle if the file has been successfully locked, which | ||||
813 | does not necessarily needs to be kept around. For instance: | ||||
814 | |||||
815 | $obj->lock('ppp', '/var/run/ppp.%p'); | ||||
816 | <do some work> | ||||
817 | $obj->unlock('ppp'); | ||||
818 | |||||
819 | or, using OO programming: | ||||
820 | |||||
821 | my $lock = $obj->lock('ppp', '/var/run/ppp.%p') ||; | ||||
822 | die "Can't lock for ppp\n"; | ||||
823 | <do some work> | ||||
824 | $lock->relase; # The only method defined for a lock handle | ||||
825 | |||||
826 | i.e. you don't even have to know which file was locked to release it, since | ||||
827 | there is a lock handle right there that knows enough about the lock parameters. | ||||
828 | |||||
829 | =item lockfile(I<file>, I<format>) | ||||
830 | |||||
831 | Simply compute the path of the I<lockfile> that would be used by the | ||||
832 | I<lock> procedure if it were passed the same parameters. | ||||
833 | |||||
834 | =item make(I<-key =E<gt> value, -key2 =E<gt> value2, ...>) | ||||
835 | |||||
836 | The creation routine for the simple lock object. Returns a blessed hash | ||||
837 | reference. | ||||
838 | |||||
839 | =item trylock(I<file>, I<format>) | ||||
840 | |||||
841 | Same as I<lock> except that it immediately returns false and does not | ||||
842 | sleep if the to-be-locked file is busy, i.e. already locked. Any | ||||
843 | stale locking file is removed, as I<lock> would do anyway. | ||||
844 | |||||
845 | Returns a lock hande if the file has been successfully locked. | ||||
846 | |||||
847 | =item unlock(I<file>) | ||||
848 | |||||
849 | Unlock the I<file>. | ||||
850 | |||||
851 | =back | ||||
852 | |||||
853 | =head1 BUGS | ||||
854 | |||||
855 | The algorithm is not bullet proof. It's only reasonably safe. Don't bet | ||||
856 | the integrity of a mission-critical database on it though. | ||||
857 | |||||
858 | The sysopen() call should probably be used with the C<O_EXCL|O_CREAT> flags | ||||
859 | to be on the safer side. Still, over NFS, this is not an atomic operation | ||||
860 | anyway. | ||||
861 | |||||
862 | B<BEWARE>: there is a race condition between the time we decide a lock is | ||||
863 | stale or too old and the time we unlink it. Don't use C<-stale> and set | ||||
864 | C<-hold> to 0 if you can't bear with that idea, but recall that this race | ||||
865 | only happens when something is already wrong. That does not make it right, | ||||
866 | nonetheless. ;-) | ||||
867 | |||||
868 | =head1 AUTHOR | ||||
869 | |||||
870 | Raphael Manfredi F<E<lt>Raphael_Manfredi@pobox.comE<gt>> | ||||
871 | |||||
872 | =head1 SEE ALSO | ||||
873 | |||||
874 | File::Flock(3). | ||||
875 | |||||
876 | =cut | ||||
877 |