| 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 | LockFile::Simple::BEGIN@72 |
| 1 | 1 | 1 | 12µs | 14µs | Tapper::Base::BEGIN@60 |
| 1 | 1 | 1 | 8µs | 63µs | LockFile::Simple::BEGIN@70 |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::_acs_check |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::_acs_lock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::_acs_stale |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::_acs_unlock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::autoclean |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::base |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::configure |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::core_warn |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::delay |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::dir |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::efunc |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::ext |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::format |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::hold |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::lock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::lock_by_file |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::locker |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::lockfile |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::make |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::manager |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::max |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::nfs |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::no_warn |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::release |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::stale |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::take_lock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::trylock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::unlock |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::wafter |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::warn |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::wfunc |
| 0 | 0 | 0 | 0s | 0s | LockFile::Simple::wmin |
| 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 |