LockFile-Simple-0.208/0000755000175000017500000000000011762230711012450 5ustar ss5ss5LockFile-Simple-0.208/MANIFEST0000644000175000017500000000134011762230711013577 0ustar ss5ss5README Read this first MANIFEST This shipping list ChangeLog List of changes Lock.pm A lock object, deferred class Lock/Simple.pm A simple lock instance Makefile.PL Generic Makefile template Manager.pm The lock manager patchlevel.h Records the current patchlevel Simple.pm The simple locking scheme t/basic.t Basic tests t/simple.t Test OO interface t/user.t Test user-defined settings META.yml Module meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) LockFile-Simple-0.208/Lock/0000755000175000017500000000000011762230711013340 5ustar ss5ss5LockFile-Simple-0.208/Lock/Simple.pm0000444000175000017500000000205711762221010015121 0ustar ss5ss5;# $Id ;# ;# @COPYRIGHT@ ;# ;# $Log: Simple.pm,v $ ;# Revision 0.3 2007/09/28 19:18:27 jv ;# Track where lock was issued in the code. ;# ;# Revision 0.2.1.1 2000/01/04 21:16:35 ram ;# patch1: track where lock was issued in the code ;# ;# Revision 0.2 1999/12/07 20:51:04 ram ;# Baseline for 0.2 release. ;# use strict; ######################################################################## package LockFile::Lock::Simple; require LockFile::Lock; use vars qw(@ISA); @ISA = qw(LockFile::Lock); # # ->make # # Creation routine # # Attributes: # # scheme the LockFile::* object that created the lock # file the locked file # format the format used to create the lockfile # filename where lock was taken # line line in filename where lock was taken # sub make { my $self = bless {}, shift; my ($scheme, $file, $format, $filename, $line) = @_; $self->{'file'} = $file; $self->{'format'} = $format; $self->_lock_init($scheme, $filename, $line); return $self; } # # Attribute access # sub file { $_[0]->{'file'} } sub format { $_[0]->{'format'} } 1; LockFile-Simple-0.208/Lock.pm0000444000175000017500000000234111762221010013664 0ustar ss5ss5;# $Id ;# ;# @COPYRIGHT@ ;# ;# $Log: Lock.pm,v $ ;# Revision 0.3 2007/09/28 19:20:14 jv ;# Track where lock was issued in the code. ;# ;# Revision 0.2.1.1 2000/01/04 21:16:28 ram ;# patch1: track where lock was issued in the code ;# ;# Revision 0.2 1999/12/07 20:51:04 ram ;# Baseline for 0.2 release. ;# use strict; ######################################################################## package LockFile::Lock; # # A lock instance -- deferred class. # # # ->_lock_init # # Common lock initialization # # Attributes: # # scheme the LockFile::* object that created the lock # filename where lock was taken # line line in filename where lock was taken # sub _lock_init { my $self = shift; my ($scheme, $filename, $line) = @_; $self->{'scheme'} = $scheme; $self->{'filename'} = $filename; $self->{'line'} = $line; } # # Common attribute access # sub scheme { $_[0]->{'scheme'} } sub filename { $_[0]->{'filename'} } sub line { $_[0]->{'line'} } # # ->release # # Release the lock # sub release { my $self = shift; return $self->scheme->release($self); } # # ->where # # Returns '"filename", line #' where lock was taken. # sub where { my $self = shift; return sprintf '"%s", line %d', $self->filename, $self->line; } 1; LockFile-Simple-0.208/README0000444000175000017500000000541311762221010013321 0ustar ss5ss5 LockFile::Simple 0.206 Copyright (c) 2000,2007, Johan Vromans LockFile::Simple 0.2 Copyright (c) 1998-1999, Raphael Manfredi ------------------------------------------------------------------------ This program is free software; you can redistribute it and/or modify it under the terms of the Perl Artistic License or the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the Artistic License for more details. ------------------------------------------------------------------------ *** This is alpha software -- use at your own risks *** Name DSLI Description Info ----------- ---- -------------------------------------------- ----- LockFile:: Application-level locking facilities ::Simple adpr Simple file locking mechanism RAM ::Lock:: ---- Lock handles created by LockFile::* schemes RAM ::Manager ---- Records locks created by LockFile::* RAM SYNOPSIS # # The simple way # use LockFile::Simple qw(lock unlock); lock("file") || die "Can't lock file\n"; open(FILE, ">>file") || die "Can't append to file: $!\n"; .... close FILE; unlock("file"); # # The more elaborated way # use LockFile::Simple; my $scheme = LockFile::Simple->make( -autoclean => 1, -format => "%f.lck"); $scheme->lock($0, "/var/run/%F.%p") || die "already running"; my $lock = $sheme->lock("file"); open(FILE, ">>file") || die "Can't append to file: $!\n"; .... close FILE; $lock->release; DESCRIPTION The LockFile::Simple extension provides simple file locking, of the advisory kind, i.e. it requires cooperation between applications wishing to lock the same files. It is meant to be used in quick-and-dirty scripts or more elaborated programs that want a simple locking scheme, yet with a reasonable level of configuration. This code comes from the mailagent-3.0 package and retains most of its configuration abilities. I do not intend to leave this simple scheme as-is forever. The code is designed to be extended to offer other locking schemes, such as MTA locking--usually a combination of this simple scheme and flock(). Despite being flagged as simple and not bullet proof all over the place, locking is good enough in practice for simple applications wishing to protect against concurrent actions. There is an embeded POD manual page in Simple.pm. -- Raphael Manfredi LockFile-Simple-0.208/META.json0000644000175000017500000000143211762230711014071 0ustar ss5ss5{ "abstract" : "unknown", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120920", "license" : [ "unknown" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "LockFile-Simple", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : {} } }, "release_status" : "stable", "version" : "0.208" } LockFile-Simple-0.208/patchlevel.h0000644000175000017500000000002511762221010014735 0ustar ss5ss5#define PATCHLEVEL 5 LockFile-Simple-0.208/META.yml0000644000175000017500000000066011762230711013723 0ustar ss5ss5--- abstract: unknown author: - unknown build_requires: ExtUtils::MakeMaker: 0 configure_requires: ExtUtils::MakeMaker: 0 dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120920' license: unknown meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: LockFile-Simple no_index: directory: - t - inc requires: {} version: 0.208 LockFile-Simple-0.208/ChangeLog0000444000175000017500000000360311762230615014225 0ustar ss5ss52012-06-01 Steffen Schwigon Fix deprecated defined(@array) for Perl 5.16 Fri Sep 28 21:20:57 CEST 2007 Johan Vromans Changed LICENSE to include GPL. Mon Sep 18 21:56:05 MEST 2000 Raphael Manfredi . Description: Fixed computation of %F and %D when no '/' in file name. Thanks to Philip Coombes for reporting the bug. Fixed OO example of lock to emphasize check on returned value. Thanks to Rob McMillin for suggesting it. Now warns when no lockfile is found during unlocking. Tue Aug 15 20:41:53 MEST 2000 Raphael Manfredi . Description: Updated version number, grrr... Tue Aug 15 20:40:49 MEST 2000 Raphael Manfredi . Description: Fixed non-working "-wfunc => undef" due to misuse of defined(). Many thanks to David Coppit for spotting it and providing the right fix. Check for stale lock while we wait for it. Untaint pid before running kill() for -T scripts. Thu Mar 2 23:35:15 MET 2000 Raphael Manfredi . Description: Allow "undef" in -efunc and -wfunc to suppress logging. Documented how to force warn() despite Log::Agent being there. Tue Jan 4 22:18:52 MET 2000 Raphael Manfredi . Description: track where lock was issued in the code logerr and logwarn are autoloaded, need to check something real forbid re-lock of a file we already locked force $\ to be undef prior to writing the PID to lockfile added simple.t and user.t to the MANIFEST Tue May 12 09:34:55 MET 1998 Raphael_Manfredi . Description: Revision history for Perl extension LockFile::Simple 0.1 Fri May 8 16:36:11 1998 - original version; created by h2xs 1.18 LockFile-Simple-0.208/Manager.pm0000444000175000017500000000355511762221010014356 0ustar ss5ss5;# $Id ;# ;# @COPYRIGHT@ ;# ;# $Log: Manager.pm,v $ ;# Revision 0.2 1999/12/07 20:51:05 ram ;# Baseline for 0.2 release. ;# use strict; ######################################################################## package LockFile::Manager; # # A pool of all created locks. # my $MANAGER = undef; # The main manager # # ->make # # Creates a new LockFile::Manager to hold the locks. # # Attributes: # # pool hash of LockFile::Lock objects # wfunc warning function to be called # efunc error function to be called # sub make { my $self = bless {}, shift; my ($wfunc, $efunc) = @_; $self->{'pool'} = {}; $self->{'wfunc'} = $wfunc; $self->{'efunc'} = $efunc; return $self; } # # Attribute access # sub pool { $_[0]->{'pool'} } sub wfunc { $_[0]->{'wfunc'} } sub efunc { $_[0]->{'efunc'} } # # ->manager -- "once" function # # Returns the main manager. # sub manager { my ($class, $wfunc, $efunc) = @_; return $MANAGER || ($MANAGER = $class->make($wfunc, $efunc)); } # # ->remember # # Remember created locks. # sub remember { my $self = shift; my ($lock) = @_; # A LockFile::Lock object my $pool = $self->pool; if (exists $pool->{$lock}) { &{$self->efunc}("lock $lock already remembered"); return; } $pool->{$lock} = $lock; } # # ->forget # # Forget about a lock. # sub forget { my $self = shift; my ($lock) = @_; # A LockFile::Lock object my $pool = $self->pool; unless (exists $pool->{$lock}) { &{$self->efunc}("lock $lock not remembered yet"); return; } delete $pool->{$lock}; } # # ->release_all # # Release all the locks. # sub release_all { my $self = shift; my $pool = $self->pool; my $locks = scalar keys %$pool; return unless $locks; my $s = $locks == 1 ? '' : 's'; &{$self->wfunc}("releasing $locks pending lock$s..."); foreach my $lock (values %$pool) { $lock->release; } } sub END { $MANAGER->release_all if defined $MANAGER } 1; LockFile-Simple-0.208/Simple.pm0000644000175000017500000006257711762227775014300 0ustar ss5ss5;# $Id$ ;# ;# @COPYRIGHT@ ;# ;# $Log: Simple.pm,v $ ;# Revision 0.4 2007/09/28 19:22:05 jv ;# Bump version. ;# ;# Revision 0.3 2007/09/28 19:19:41 jv ;# Revision 0.2.1.5 2000/09/18 19:55:07 ram ;# patch5: fixed computation of %F and %D when no '/' in file name ;# patch5: fixed OO example of lock to emphasize check on returned value ;# patch5: now warns when no lockfile is found during unlocking ;# ;# Revision 0.2.1.4 2000/08/15 18:41:43 ram ;# patch4: updated version number, grrr... ;# ;# Revision 0.2.1.3 2000/08/15 18:37:37 ram ;# patch3: fixed non-working "-wfunc => undef" due to misuse of defined() ;# patch3: check for stale lock while we wait for it ;# patch3: untaint pid before running kill() for -T scripts ;# ;# Revision 0.2.1.2 2000/03/02 22:35:02 ram ;# patch2: allow "undef" in -efunc and -wfunc to suppress logging ;# patch2: documented how to force warn() despite Log::Agent being there ;# ;# Revision 0.2.1.1 2000/01/04 21:18:10 ram ;# patch1: logerr and logwarn are autoloaded, need to check something real ;# patch1: forbid re-lock of a file we already locked ;# patch1: force $\ to be undef prior to writing the PID to lockfile ;# patch1: track where lock was issued in the code ;# ;# Revision 0.2.1.5 2000/09/18 19:55:07 ram ;# patch5: fixed computation of %F and %D when no '/' in file name ;# patch5: fixed OO example of lock to emphasize check on returned value ;# patch5: now warns when no lockfile is found during unlocking ;# ;# Revision 0.2.1.4 2000/08/15 18:41:43 ram ;# patch4: updated version number, grrr... ;# ;# Revision 0.2.1.3 2000/08/15 18:37:37 ram ;# patch3: fixed non-working "-wfunc => undef" due to misuse of defined() ;# patch3: check for stale lock while we wait for it ;# patch3: untaint pid before running kill() for -T scripts ;# ;# Revision 0.2.1.2 2000/03/02 22:35:02 ram ;# patch2: allow "undef" in -efunc and -wfunc to suppress logging ;# patch2: documented how to force warn() despite Log::Agent being there ;# ;# Revision 0.2.1.1 2000/01/04 21:18:10 ram ;# patch1: logerr and logwarn are autoloaded, need to check something real ;# patch1: forbid re-lock of a file we already locked ;# patch1: force $\ to be undef prior to writing the PID to lockfile ;# patch1: track where lock was issued in the code ;# ;# Revision 0.2 1999/12/07 20:51:05 ram ;# Baseline for 0.2 release. ;# use strict; ######################################################################## package LockFile::Simple; # # This package extracts the simple locking logic used by mailagent-3.0 # into a standalone Perl module to be reused in other applications. # use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use Sys::Hostname; require Exporter; require LockFile::Lock::Simple; eval "use Log::Agent"; @ISA = qw(Exporter); @EXPORT = (); @EXPORT_OK = qw(lock trylock unlock); $VERSION = '0.208'; my $LOCKER = undef; # Default locking object # # ->make # # Create a file locking object, responsible for holding the locking # parameters to be used by all the subsequent locks requested from # this locking object. # # Configuration attributes: # # autoclean keep track of locks and release pending one at END time # max max number of attempts # delay seconds to wait between attempts # format how to derive lockfile from file to be locked # hold max amount of seconds before breaking lock (0 for never) # ext lock extension # nfs true if lock must "work" on top of NFS # stale try to detect stale locks via SIGZERO and delete them # warn flag to turn warnings on # wmin warn once after that many waiting seconds # wafter warn every that many seconds after first warning # wfunc warning function to be called # efunc error function to be called # # Additional attributes: # # manager lock manager, used when autoclean # lock_by_file returns lock by filename # # The creation routine first and sole argument is a "hash table list" listing # all the configuration attributes. Missing attributes are given a default # value. A call to ->configure can alter the configuration parameters of # an existing object. # sub make { my $self = bless {}, shift; my (@hlist) = @_; # Set configuration defaults, then override with user preferences $self->{'max'} = 30; $self->{'delay'} = 2; $self->{'hold'} = 3600; $self->{'ext'} = '.lock'; $self->{'nfs'} = 0; $self->{'stale'} = 0; $self->{'warn'} = 1; $self->{'wmin'} = 15; $self->{'wafter'} = 20; $self->{'autoclean'} = 0; $self->{'lock_by_file'} = {}; # The logxxx routines are autoloaded, so need to check for @EXPORT $self->{'wfunc'} = @Log::Agent::EXPORT ? \&logwarn : \&core_warn; $self->{'efunc'} = @Log::Agent::EXPORT ? \&logerr : \&core_warn; $self->configure(@hlist); # Will init "manager" if necessary return $self; } # # ->locker -- "once" function # # Compute the default locking object. # sub locker { return $LOCKER || ($LOCKER = LockFile::Simple->make('-warn' => 1)); } # # ->configure # # Extract known configuration parameters from the specified hash list # and use their values to change the object's corresponding parameters. # # Parameters are specified as (-warn => 1, -ext => '.lock') for instance. # sub configure { my $self = shift; my (%hlist) = @_; my @known = qw( autoclean max delay hold format ext nfs warn wfunc wmin wafter efunc stale ); foreach my $attr (@known) { $self->{$attr} = $hlist{"-$attr"} if exists $hlist{"-$attr"}; } $self->{'wfunc'} = \&no_warn unless defined $self->{'wfunc'}; $self->{'efunc'} = \&no_warn unless defined $self->{'efunc'}; if ($self->autoclean) { require LockFile::Manager; # Created via "once" function $self->{'manager'} = LockFile::Manager->manager( $self->wfunc, $self->efunc); } } # # Attribute access # sub max { $_[0]->{'max'} } sub delay { $_[0]->{'delay'} } sub format { $_[0]->{'format'} } sub hold { $_[0]->{'hold'} } sub nfs { $_[0]->{'nfs'} } sub stale { $_[0]->{'stale'} } sub ext { $_[0]->{'ext'} } sub warn { $_[0]->{'warn'} } sub wmin { $_[0]->{'wmin'} } sub wafter { $_[0]->{'wafter'} } sub wfunc { $_[0]->{'wfunc'} } sub efunc { $_[0]->{'efunc'} } sub autoclean { $_[0]->{'autoclean'} } sub lock_by_file { $_[0]->{'lock_by_file'} } sub manager { $_[0]->{'manager'} } # # Warning and error reporting -- Log::Agent used only when available # sub core_warn { CORE::warn(@_) } sub no_warn { return } # # ->lock # # Lock specified file, possibly using alternate file "format". # Returns whether file was locked or not at the end of the configured # blocking period by providing the LockFile::Lock instance if successful. # # For quick and dirty scripts wishing to use locks, create the locking # object if not invoked as a method, turning on warnings. # sub lock { my $self = shift; unless (ref $self) { # Not invoked as a method unshift(@_, $self); $self = locker(); } my ($file, $format) = @_; # File to be locked, lock format return $self->take_lock($file, $format, 0); } # # ->trylock # # Attempt to lock specified file, possibly using alternate file "format". # If the file is already locked, don't block and return undef. The # LockFile::Lock instance is returned upon success. # # For quick and dirty scripts wishing to use locks, create the locking # object if not invoked as a method, turning on warnings. # sub trylock { my $self = shift; unless (ref $self) { # Not invoked as a method unshift(@_, $self); $self = locker(); } my ($file, $format) = @_; # File to be locked, lock format return $self->take_lock($file, $format, 1); } # # ->take_lock # # Common code for ->lock and ->trylock. # Returns a LockFile::Lock object on success, undef on failure. # sub take_lock { my $self = shift; my ($file, $format, $tryonly) = @_; # # If lock was already taken by us, it's an error when $tryonly is 0. # Otherwise, simply fail to get the lock. # my $lock = $self->lock_by_file->{$file}; if (defined $lock) { my $where = $lock->where; &{$self->efunc}("file $file already locked at $where") unless $tryonly; return undef; } my $locked = $self->_acs_lock($file, $format, $tryonly); return undef unless $locked; # # Create LockFile::Lock object # my ($package, $filename, $line) = caller(1); $lock = LockFile::Lock::Simple->make($self, $file, $format, $filename, $line); $self->manager->remember($lock) if $self->autoclean; $self->lock_by_file->{$file} = $lock; return $lock; } # # ->unlock # # Unlock file. # Returns true if file was unlocked. # sub unlock { my $self = shift; unless (ref $self) { # Not invoked as a method unshift(@_, $self); $self = locker(); } my ($file, $format) = @_; # File to be unlocked, lock format if (defined $format) { require Carp; Carp::carp("2nd argument (format) is no longer needed nor used"); } # # Retrieve LockFile::Lock object # my $lock = $self->lock_by_file->{$file}; unless (defined $lock) { &{$self->efunc}("file $file not currently locked"); return undef; } return $self->release($lock); } # # ->release -- not exported (i.e. not documented) # # Same a unlock, but we're passed a LockFile::Lock object. # And we MUST be called as a method (usually via LockFile::Lock, not user code). # # Returns true if file was unlocked. # sub release { my $self = shift; my ($lock) = @_; my $file = $lock->file; my $format = $lock->format; $self->manager->forget($lock) if $self->autoclean; delete $self->lock_by_file->{$file}; return $self->_acs_unlock($file, $format); } # # ->lockfile # # Return the name of the lockfile, given the file name to lock and the custom # string provided by the user. The following macros are substituted: # %D: the file dir name # %f: the file name (full path) # %F: the file base name (last path component) # %p: the process's pid # %%: a plain % character # sub lockfile { my $self = shift; my ($file, $format) = @_; local $_ = defined($format) ? $format : $self->format; s/%%/\01/g; # Protect double percent signs s/%/\02/g; # Protect against substitutions adding their own % s/\02f/$file/g; # %f is the full path name s/\02D/&dir($file)/ge; # %D is the dir name s/\02F/&base($file)/ge; # %F is the base name s/\02p/$$/g; # %p is the process's pid s/\02/%/g; # All other % kept as-is s/\01/%/g; # Restore escaped % signs $_; } # Return file basename (last path component) sub base { my ($file) = @_; my ($base) = $file =~ m|^.*/(.*)|; return ($base eq '') ? $file : $base; } # Return dirname sub dir { my ($file) = @_; my ($dir) = $file =~ m|^(.*)/.*|; return ($dir eq '') ? '.' : $dir; } # # _acs_lock -- private # # Internal locking routine. # # If $try is true, don't wait if the file is already locked. # Returns true if the file was locked. # sub _acs_lock { ## private my $self = shift; my ($file, $format, $try) = @_; my $max = $self->max; my $delay = $self->delay; my $stamp = $$; # For NFS, we need something more unique than the process's PID $stamp .= ':' . hostname if $self->nfs; # Compute locking file name -- hardwired default format is "%f.lock" my $lockfile = $file . $self->ext; $format = $self->format unless defined $format; $lockfile = $self->lockfile($file, $format) if defined $format; # Detect stale locks or break lock if held for too long $self->_acs_stale($file, $lockfile) if $self->stale; $self->_acs_check($file, $lockfile) if $self->hold; my $waited = 0; # Amount of time spent sleeping my $lastwarn = 0; # Last time we warned them... my $warn = $self->warn; my ($wmin, $wafter, $wfunc); ($wmin, $wafter, $wfunc) = ($self->wmin, $self->wafter, $self->wfunc) if $warn; my $locked = 0; my $mask = umask(0333); # No write permission local *FILE; while ($max-- > 0) { if (-f $lockfile) { next unless $try; umask($mask); return 0; # Already locked } # Attempt to create lock if (open(FILE, ">$lockfile")) { local $\ = undef; print FILE "$stamp\n"; close FILE; open(FILE, $lockfile); # Check lock my $l; chop($l = ); $locked = $l eq $stamp; $l = ; # Must be EOF $locked = 0 if defined $l; close FILE; last if $locked; # Lock seems to be ours } elsif ($try) { umask($mask); return 0; # Already locked, or cannot create lock } } continue { sleep($delay); # Busy: wait $waited += $delay; # Warn them once after $wmin seconds and then every $wafter seconds if ( $warn && ((!$lastwarn && $waited > $wmin) || ($waited - $lastwarn) > $wafter) ) { my $waiting = $lastwarn ? 'still waiting' : 'waiting'; my $after = $lastwarn ? 'after' : 'since'; my $s = $waited == 1 ? '' : 's'; &$wfunc("$waiting for $file lock $after $waited second$s"); $lastwarn = $waited; } # While we wait, existing lockfile may become stale or too old $self->_acs_stale($file, $lockfile) if $self->stale; $self->_acs_check($file, $lockfile) if $self->hold; } umask($mask); return $locked; } # # ->_acs_unlock -- private # # Unlock file. If lock format is specified, it must match the one used # at lock time. # # Return true if file was indeed locked by us and is now properly unlocked. # sub _acs_unlock { ## private my $self = shift; my ($file, $format) = @_; # Locked file, locking format my $stamp = $$; $stamp .= ':' . hostname if $self->nfs; # Compute locking file name -- hardwired default format is "%f.lock" my $lockfile = $file . $self->ext; $format = $self->format unless defined $format; $lockfile = $self->lockfile($file, $format) if defined $format; local *FILE; my $unlocked = 0; if (-f $lockfile) { open(FILE, $lockfile); my $l; chop($l = ); close FILE; if ($l eq $stamp) { # Pid (plus hostname possibly) is OK $unlocked = 1; unless (unlink $lockfile) { $unlocked = 0; &{$self->efunc}("cannot unlock $file: $!"); } } else { &{$self->efunc}("cannot unlock $file: lock not owned"); } } else { &{$self->wfunc}("no lockfile found for $file"); } return $unlocked; # Did we successfully unlock? } # # ->_acs_check # # Make sure lock lasts only for a reasonable time. If it has expired, # then remove the lockfile. # # This is not enabled by default because there is a race condition between # the time we stat the file and the time we unlink the lockfile. # sub _acs_check { my $self = shift; my ($file, $lockfile) = @_; my $mtime = (stat($lockfile))[9]; return unless defined $mtime; # Assume file does not exist my $hold = $self->hold; # If file too old to be considered stale? if ((time - $mtime) > $hold) { # RACE CONDITION -- shall we lock the lockfile? unless (unlink $lockfile) { &{$self->efunc}("cannot unlink $lockfile: $!"); return; } if ($self->warn) { my $s = $hold == 1 ? '' : 's'; &{$self->wfunc}("UNLOCKED $file (lock older than $hold second$s)"); } } } # # ->_acs_stale # # Detect stale locks and remove them. This works by sending a SIGZERO to # the pid held in the lockfile. If configured for NFS, only processes # on the same host than the one holding the lock will be able to perform # the check. # # Stale lock detection is not enabled by default because there is a race # condition between the time we check for the pid, and the time we unlink # the lockfile: we could well be unlinking a new lockfile created inbetween. # sub _acs_stale { my $self = shift; my ($file, $lockfile) = @_; local *FILE; open(FILE, $lockfile) || return; my $stamp; chop($stamp = ); close FILE; my ($pid, $hostname); if ($self->nfs) { ($pid, $hostname) = $stamp =~ /^(\d+):(\S+)/; my $local = hostname; return if $local ne $hostname; return if kill 0, $pid; $hostname = " on $hostname"; } else { ($pid) = $stamp =~ /^(\d+)$/; # Untaint $pid for kill() $hostname = ''; return if kill 0, $pid; } # RACE CONDITION -- shall we lock the lockfile? unless (unlink $lockfile) { &{$self->efunc}("cannot unlink stale $lockfile: $!"); return; } &{$self->wfunc}("UNLOCKED $file (stale lock by PID $pid$hostname)"); } 1; ######################################################################## =head1 NAME LockFile::Simple - simple file locking scheme =head1 SYNOPSIS use LockFile::Simple qw(lock trylock unlock); # Simple locking using default settings lock("/some/file") || die "can't lock /some/file\n"; warn "already locked\n" unless trylock("/some/file"); unlock("/some/file"); # Build customized locking manager object $lockmgr = LockFile::Simple->make(-format => '%f.lck', -max => 20, -delay => 1, -nfs => 1); $lockmgr->lock("/some/file") || die "can't lock /some/file\n"; $lockmgr->trylock("/some/file"); $lockmgr->unlock("/some/file"); $lockmgr->configure(-nfs => 0); # Using lock handles my $lock = $lockmgr->lock("/some/file"); $lock->release; =head1 DESCRIPTION This simple locking scheme is not based on any file locking system calls such as C or C but rather relies on basic file system primitives and properties, such as the atomicity of the C system call. It is not meant to be exempt from all race conditions, especially over NFS. The algorithm used is described below in the B section. It is possible to customize the locking operations to attempt locking once every 5 seconds for 30 times, or delete stale locks (files that are deemed too ancient) before attempting the locking. =head1 ALGORITHM The locking alogrithm attempts to create a I using a temporarily redefined I (leaving only read rights to prevent further create operations). It then writes the process ID (PID) of the process and closes the file. That file is then re-opened and read. If we are able to read the same PID we wrote, and only that, we assume the locking is successful. When locking over NFS, i.e. when the one of the potentially locking processes could access the I via NFS, then writing the PID is not enough. We also write the hostname where locking is attempted to ensure the data are unique. =head1 CUSTOMIZING Customization is only possible by using the object-oriented interface, since the configuration parameters are stored within the object. The object creation routine C can be given configuration parmeters in the form a "hash table list", i.e. a list of key/value pairs. Those parameters can later be changed via C by specifying a similar list of key/value pairs. To benefit from the bareword quoting Perl offers, all the parameters must be prefixed with the C<-> (minus) sign, as in C<-format> for the I parameter.. However, when querying the object, the minus must be omitted, as in C<$obj-Eformat>. Here are the available configuration parmeters along with their meaning, listed in alphabetical order: =over 4 =item I When true, all locks are remembered and pending ones are automatically released when the process exits normally (i.e. whenever Perl calls the END routines). =item I The amount of seconds to wait between locking attempts when the file appears to be already locked. Default is 2 seconds. =item I A function pointer to dereference when an error is to be reported. By default, it redirects to the logerr() routine if you have Log::Agent installed, to Perl's warn() function otherwise. You may set it explicitely to C<\&LockFile::Simple::core_warn> to force the use of Perl's warn() function, or to C to suppress logging. =item I The locking extension that must be added to the file path to be locked to compute the I path. Default is C<.lock> (note that C<.> is part of the extension and can therefore be changed). Ignored when I is also used. =item I Using this parmeter supersedes the I parmeter. The formatting string specified is run through a rudimentary macro expansion to derive the I path from the file to be locked. The following macros are available: %% A real % sign %f The full file path name %D The directory where the file resides %F The base name of the file %p The process ID (PID) The default is to use the locking extension, which itself is C<.lock>, so it is as if the format used was C<%f.lock>, but one could imagine things like C, i.e. the I does not necessarily lie besides the locked file (which could even be missing). When locking, the locking format can be specified to supersede the object configuration itself. =item I Maximum amount of seconds we may hold a lock. Past that amount of time, an existing I is removed, being taken for a stale lock. Default is 3600 seconds. Specifying 0 prevents any forced unlocking. =item I Amount of times we retry locking when the file is busy, sleeping I seconds between attempts. Defaults to 30. =item I A boolean flag, false by default. Setting it to true means we could lock over NFS and therefore the hostname must be included along with the process ID in the stamp written to the lockfile. =item I A boolean flag, false by default. When set to true, we attempt to detect stale locks and break them if necessary. =item I Stands for I. It is the number of seconds past the first warning during locking time after which a new warning should be emitted. See I and I below. Default is 20. =item I A boolean flag, true by default. To suppress any warning, set it to false. =item I A function pointer to dereference when a warning is to be issued. By default, it redirects to the logwarn() routine if you have Log::Agent installed, to Perl's warn() function otherwise. You may set it explicitely to C<\&LockFile::Simple::core_warn> to force the use of Perl's warn() function, or to C to suppress logging. =item I The minimal amount of time when waiting for a lock after which a first warning must be emitted, if I is true. After that, a warning will be emitted every I seconds. Defaults to 15. =back Each of those configuration attributes can be queried on the object directly: $obj = LockFile::Simple->make(-nfs => 1); $on_nfs = $obj->nfs; Those are pure query routines, i.e. you cannot say: $obj->nfs(0); # WRONG $obj->configure(-nfs => 0); # Right to turn of the NFS attribute. That is because my OO background chokes at having querying functions with side effects. =head1 INTERFACE The OO interface documented below specifies the signature and the semantics of the operations. Only the C, C and C operation can be imported and used via a non-OO interface, with the exact same signature nonetheless. The interface contains all the attribute querying routines, one for each configuration parmeter documented in the B section above, plus, in alphabetical order: =over 4 =item configure(I<-key =E value, -key2 =E value2, ...>) Change the specified configuration parameters and silently ignore the invalid ones. =item lock(I, I) Attempt to lock the file, using the optional locking I if specified, otherwise using the default I scheme configured in the object, or by simply appending the I extension to the file. If the file is already locked, sleep I seconds before retrying, repeating try/sleep at most I times. If warning is configured, a first warning is emitted after waiting for I seconds, and then once every I seconds, via the I routine. Before the first attempt, and if I is non-zero, any existing I is checked for being too old, and it is removed if found to be stale. A warning is emitted via the I routine in that case, if allowed. Likewise, if I is non-zero, a check is made to see whether any locking process is still around (only if the lock holder is on the same machine when NFS locking is configured). Should the locking process be dead, the I is declared stale and removed. Returns a lock handle if the file has been successfully locked, which does not necessarily needs to be kept around. For instance: $obj->lock('ppp', '/var/run/ppp.%p'); $obj->unlock('ppp'); or, using OO programming: my $lock = $obj->lock('ppp', '/var/run/ppp.%p') ||; die "Can't lock for ppp\n"; $lock->relase; # The only method defined for a lock handle i.e. you don't even have to know which file was locked to release it, since there is a lock handle right there that knows enough about the lock parameters. =item lockfile(I, I) Simply compute the path of the I that would be used by the I procedure if it were passed the same parameters. =item make(I<-key =E value, -key2 =E value2, ...>) The creation routine for the simple lock object. Returns a blessed hash reference. =item trylock(I, I) Same as I except that it immediately returns false and does not sleep if the to-be-locked file is busy, i.e. already locked. Any stale locking file is removed, as I would do anyway. Returns a lock hande if the file has been successfully locked. =item unlock(I) Unlock the I. =back =head1 BUGS The algorithm is not bullet proof. It's only reasonably safe. Don't bet the integrity of a mission-critical database on it though. The sysopen() call should probably be used with the C flags to be on the safer side. Still, over NFS, this is not an atomic operation anyway. B: there is a race condition between the time we decide a lock is stale or too old and the time we unlink it. Don't use C<-stale> and set C<-hold> to 0 if you can't bear with that idea, but recall that this race only happens when something is already wrong. That does not make it right, nonetheless. ;-) =head1 AUTHOR Raphael Manfredi FRaphael_Manfredi@pobox.comE> =head1 SEE ALSO File::Flock(3). =cut LockFile-Simple-0.208/Makefile.PL0000644000175000017500000000065411762221010014417 0ustar ss5ss5# $Id: Makefile.PL,v 0.2 1999/12/07 20:51:05 ram Exp ram $ # # @COPYRIGHT@ # # $Log: Makefile.PL,v $ # Revision 0.2 1999/12/07 20:51:05 ram # Baseline for 0.2 release. # use ExtUtils::MakeMaker; WriteMakefile( 'NAME' => 'LockFile::Simple', 'VERSION_FROM' => 'Simple.pm', # finds $VERSION 'PMLIBDIRS' => [ 'Lock' ], 'dist' => { SUFFIX => 'gz', COMPRESS => 'gzip -f' }, 'clean' => {'FILES' => '*%'}, ); LockFile-Simple-0.208/t/0000755000175000017500000000000011762230711012713 5ustar ss5ss5LockFile-Simple-0.208/t/basic.t0000644000175000017500000000076211762221010014156 0ustar ss5ss5#!./perl # $Id: basic.t,v 0.2 1999/12/07 20:51:05 ram Exp ram $ # # @COPYRIGHT@ # # $Log: basic.t,v $ # Revision 0.2 1999/12/07 20:51:05 ram # Baseline for 0.2 release. # use LockFile::Simple qw(lock trylock unlock); print "1..5\n"; unlink 't.lock'; print "not " unless lock('t'); print "ok 1\n"; print "not " unless -r 't.lock'; print "ok 2\n"; print "not " if trylock('t'); print "ok 3\n"; print "not " unless unlock('t'); print "ok 4\n"; print "not " if -f 't.lock'; print "ok 5\n"; LockFile-Simple-0.208/t/user.t0000644000175000017500000000071411762221010014050 0ustar ss5ss5#!./perl # $Id: user.t,v 0.2 1999/12/07 20:51:05 ram Exp ram $ # # @COPYRIGHT@ # # $Log: user.t,v $ # Revision 0.2 1999/12/07 20:51:05 ram # Baseline for 0.2 release. # use LockFile::Simple qw(lock trylock unlock); print "1..2\n"; my $locker = LockFile::Simple->make( -nfs => 1, # may happen over NFS -hold => 0, # no forced unlocking ); print "not " unless $locker->hold == 0; print "ok 1\n"; print "not " unless $locker->nfs == 1; print "ok 2\n"; LockFile-Simple-0.208/t/simple.t0000444000175000017500000000215611762221010014363 0ustar ss5ss5#!./perl # $Id: simple.t,v 0.3 2007/09/28 19:18:46 jv Exp $ # # @COPYRIGHT@ # # $Log: simple.t,v $ # Revision 0.3 2007/09/28 19:18:46 jv # Forgot to remove "t.mark". # # Revision 0.2.1.1 2000/08/15 18:37:45 ram # patch3: forgot to remove "t.mark" # # Revision 0.2 1999/12/07 20:51:05 ram # Baseline for 0.2 release. # use LockFile::Simple; $| = 1; # We're going to fork print "1..6\n"; # # Basic tests made via the OO interface. # my $manager = LockFile::Simple->make; unlink 't.lock'; my $lock = $manager->lock('t'); print "not " unless ref $lock; print "ok 1\n"; print "not " unless -r 't.lock'; print "ok 2\n"; print "not " if $manager->trylock('t'); print "ok 3\n"; print "not " unless $manager->unlock('t'); print "ok 4\n"; print "not " if -f 't.lock'; print "ok 5\n"; # # Autocleaning # sub mark { my ($msg) = join(' ', @_); open(MARK, ">t.mark"); print MARK "$msg\n"; close MARK; } $manager = LockFile::Simple->make(-autoclean => 1, -wfunc => \&mark); unlink 't.mark'; if (0 == fork()) { $manager->lock('t'); exit 0; } wait; print "not " unless -r 't.mark'; print "ok 6\n"; unlink 't.mark';