Profile of LockFile/Simple.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:52 2012

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 588µs | 887µs | LockFile::Simple::::BEGIN@72LockFile::Simple::BEGIN@72
1 | 1 | 1 | 12µs | 14µs | Tapper::Base::::BEGIN@60 Tapper::Base::BEGIN@60
1 | 1 | 1 | 8µs | 63µs | LockFile::Simple::::BEGIN@70LockFile::Simple::BEGIN@70
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::_acs_checkLockFile::Simple::_acs_check
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::_acs_lockLockFile::Simple::_acs_lock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::_acs_staleLockFile::Simple::_acs_stale
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::_acs_unlockLockFile::Simple::_acs_unlock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::autocleanLockFile::Simple::autoclean
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::baseLockFile::Simple::base
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::configureLockFile::Simple::configure
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::core_warnLockFile::Simple::core_warn
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::delayLockFile::Simple::delay
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::dirLockFile::Simple::dir
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::efuncLockFile::Simple::efunc
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::extLockFile::Simple::ext
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::formatLockFile::Simple::format
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::holdLockFile::Simple::hold
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::lockLockFile::Simple::lock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::lock_by_fileLockFile::Simple::lock_by_file
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::lockerLockFile::Simple::locker
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::lockfileLockFile::Simple::lockfile
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::makeLockFile::Simple::make
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::managerLockFile::Simple::manager
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::maxLockFile::Simple::max
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::nfsLockFile::Simple::nfs
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::no_warnLockFile::Simple::no_warn
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::releaseLockFile::Simple::release
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::staleLockFile::Simple::stale
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::take_lockLockFile::Simple::take_lock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::trylockLockFile::Simple::trylock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::unlockLockFile::Simple::unlock
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::wafterLockFile::Simple::wafter
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::warnLockFile::Simple::warn
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::wfuncLockFile::Simple::wfunc
0 | 0 | 0 | 0s | 0s | LockFile::Simple::::wminLockFile::Simple::wmin

Call graph for these subroutines as a Graphviz dot language file.

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 use strict; # 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 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); # 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 use Sys::Hostname; # 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 |  |  |  |  |