I've attached my filelock.pm module here, maybe it will help you. It's worked for me under a variety of Linux systems, NetBSD, and a variety of Windows32 (W2K, WXP, Server 2000, Server 2003).
It operates on the principle that anyone touching the file will first request a lock on it, and will release it when they are done. The lock itself is another file (the filename you request plus a .lck), so you'll need to have sufficient access to be able to create files in the directory where your target file is located.
It does NOT have any robust timeout features; I wrote the module for myself and it worked for me so I simply trust me to only use it when I know all access points will respect the rules. Back of my mind to do list included enhancing it to permit timeouts and that sort of thing, but as yet I've not picked up the design brain to that end.
In any regard, the module works for me in all environments but one. It used to work in that environment, but the hosting provider did some kind of OS switch and since then I have been getting errors about how the lock limit has been exceeded or somesuch. I don't understand why, but it's the only place I have ever had a problem with this module.
Since the hosting provider was of little help, I've dropped the use of filelock.pm on that site. The application in question has two users and extremely low transaction volume, so we both just cross our fingers a lot.
I have been contemplating finding another mechanism by which to establish locking without using flock() but haven't really put my fingers to the keyboard on it.
Nonetheless, this worked for me for many years with this one web hosting provider being the only time it had failed, and only when they switched OS for their servers.
Good luck! And I wouldn't mind hearing if you try using this to find out if it works or not.
#!/usr/bin/perl use strict; # ==================================================================== +========== # Module-wide Information # ==================================================================== +========== # -------------------------------------------------------------------- +---------- # Module name and description # -------------------------------------------------------------------- +---------- package filelock; # -------------------------------------------------------------------- +---------- # Modules we use # -------------------------------------------------------------------- +---------- use Fcntl qw(:DEFAULT :flock); # -------------------------------------------------------------------- +---------- # Constants (Operationally, if not technically) # -------------------------------------------------------------------- +---------- my $VERMAJ = 1; # Major version number (' +1' in 'v1.02c') my $VERMIN = 10; # Minor version number ('2' + in 'v1.02c') my $VERSFX = ''; # Version suffix ('c' in 'v +1.02c') # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= our $RET_SUCCESS = 0; our $RET_FAILURE = (-1); our $RET_FATAL = (-2); our $RET_ALREADYLOCKED = (-3); our $RET_ALREADYUNLOCKED = (-4); our $RET_NEGLOCKCNT = (-5); our $RET_NEVERLOCKED = (-6); # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= my $TRUE = 1; my $FALSE = 0; my $DFT_LCKEXT = '.lck'; # Default lock filename ext +ension my $KEY_HIGHAN = 'HIGHAN'; # Master lock counter has +h key my $KEY_LCKHAN = 'LCKHAN'; # Handle top-of-tree key my $KEY_LCKCNT = 'LCKCNT'; # Per-file Lock count top +-of-tree key my $MST_LCKHAN = 'LCKFIL'; # Base portion of lock fi +le handle my $NVRLCK = (-1); # Magic lock count return + flagging "never been locked" # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= # -------------------------------------------------------------------- +---------- # Globals # -------------------------------------------------------------------- +---------- my $Tstflg = 0; # Are we in Unit Test mode? my %Lckhan; # Lock token file handles # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= # -------------------------------------------------------------------- +---------- # Initializers # -------------------------------------------------------------------- +---------- # -------------------------------------------------------------------- +---------- # None # -------------------------------------------------------------------- +---------- # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= # ==================================================================== +========== # Subroutines # ==================================================================== +========== # -------------------------------------------------------------------- +---------- # version() - Returns the version number of this module # -------------------------------------------------------------------- +---------- sub version { return sprintf "%d.%02d%s", $VERMAJ, $VERMIN, $VERSFX; } # -------------------------------------------------------------------- +---------- # setTestMode($tstmod) - Sets (or clears) the unit test mode indicator # $tstmod: Whether or not test mode should be on # # Returns: The previous setting of the test mode # -------------------------------------------------------------------- +---------- sub setTestMode { my ($tstmod, @arglst) = @_; my $oldmod = $Tstflg; $Tstflg = $tstmod; return $oldmod; } # -------------------------------------------------------------------- +---------- # getTestMode() - Returns the current test mode setting # Returns: The current setting of the test mode # -------------------------------------------------------------------- +---------- sub getTestMode { return $Tstflg; } # -------------------------------------------------------------------- +---------- # initLockCount($filfnm) - Initializes the lock count for a file # $filfnm: The filename to initement the lock counter # # Returns: The new lock counter (which will be 0) # # NOTE: Also establishes the unique lock token file handle for this f +ilename # -------------------------------------------------------------------- +---------- sub initLockCount { my ($filfnm, @arglst) = @_; $Lckhan{$KEY_LCKCNT}{$filfnm} = 0; # If necessary, geneate unique lock handle and store. if (!defined $Lckhan{$KEY_HIGHAN}) { # No Lock handle counter. Initialize. $Lckhan{$KEY_HIGHAN} = 0; } if (!defined $Lckhan{$KEY_LCKHAN}{$filfnm}) { $Lckhan{$KEY_HIGHAN}++; # Unique lock handle number $Lckhan{$KEY_LCKHAN}{$filfnm} = $MST_LCKHAN . $Lckhan{$KEY_HIG +HAN}; #DEBUG print "Handle for '$filfnm' is ", $Lckhan{$KEY_LCKHAN}{ +$filfnm}; } #DEBUG print "Lock count for '$filfnm' is now ", $Lckhan{$KEY_LCKC +NT}{$filfnm}; return $Lckhan{$KEY_LCKCNT}{$filfnm}; } # -------------------------------------------------------------------- +---------- # incrLockCount($filfnm) - Increments the lock count for a file # $filfnm: The filename to increment the lock counter # # Returns: The new lock counter # -------------------------------------------------------------------- +---------- sub incrLockCount { my ($filfnm, @arglst) = @_; my $lckcnt = getLockCount($filfnm); if ($lckcnt eq $NVRLCK) { $lckcnt = &initLockCount($filfnm); } $lckcnt++; $Lckhan{$KEY_LCKCNT}{$filfnm} = $lckcnt; return $lckcnt; } # -------------------------------------------------------------------- +---------- # decrLockCount($filfnm) - Decrements the lock count for a file # $filfnm: The filename to decrement the lock counter # # Returns: The new lock counter # -------------------------------------------------------------------- +---------- sub decrLockCount { my ($filfnm, @arglst) = @_; my $lckcnt = $Lckhan{$KEY_LCKCNT}{$filfnm}; $lckcnt--; $Lckhan{$KEY_LCKCNT}{$filfnm} = $lckcnt; return $lckcnt; } # -------------------------------------------------------------------- +---------- # getLockCount($filfnm) - Returns the current test mode setting # $filfnm: The filename to decrement the lock counter # # Returns: The current Lock Count for the file or $NVRLCK if nev +er locked # -------------------------------------------------------------------- +---------- sub getLockCount { my ($filfnm, @arglst) = @_; if (!defined $Lckhan{$KEY_LCKCNT}{$filfnm}) { # Not defined. File has never been locked in this session. return $NVRLCK; } else { return $Lckhan{$KEY_LCKCNT}{$filfnm}; } } # -------------------------------------------------------------------- +---------- # lock($filfnm) - Requests a lock token for a file # $filfnm: The filename to take out a lock upon # Returns: $RET_SUCCESS or an error number # -------------------------------------------------------------------- +---------- sub lock() { my ($filfnm, @arglst) = @_; #DEBUG print "Process $$ attempting access"; my $lckfnm = &_getLockFilename($filfnm); # Lock token filename +for this file # Increment lock counter my $lckcnt = &incrLockCount($filfnm); #DEBUG print "Lock count for '$filfnm' is now $lckcnt"; # If this is the first lock, create and open the lock token file s +o flock() can grab it if ($lckcnt == 1) { # First lock. Do lock token management. { # Must disable warnings and strict for this no warnings; no strict; if (!(sysopen($Lckhan{$KEY_LCKHAN}{$filfnm}, "$lckfnm", O_ +WRONLY | O_CREAT))) { # Error opening the lock token file. print "ERROR: Cannot open lock file '$lckfnm' (Error: + $!)\n"; return $RET_BADOPEN; } } # Lock (and empty) the lock token file { # Must disable warnings and strict for this no warnings; no strict; if (!(flock($Lckhan{$KEY_LCKHAN}{$filfnm}, LOCK_EX))) { # Unable to get the atomic lock for some reason. print "ERROR: Cannot lock lock file '$lckfnm' (Error: + $!)\n"; return $RET_BADLOCK; } } { # Must disable warnings and strict for this no warnings; no strict; if (!(truncate($Lckhan{$KEY_LCKHAN}{$filfnm}, 0))) { # Unable to truncate (possibly means lock failed) # Seems to fail under normal usage if the lockfile did + not previously exist. # However, it functions correctly. So don't report th +is error as an error. # So these next two commands are commented out for thi +s reason. #print "ERROR: Cannot truncate lock file '$lckfnm' (E +rror: $!)\n"; #return $RET_BADTRUNCATE; } } } #DEBUG print "Process $$ has gained access"; return $RET_SUCCESS; } # -------------------------------------------------------------------- +---------- # unlock($filfnm) - Releases a lock token for a file # $filfnm: The filename to release the lock for # Returns: $RET_SUCCESS or an error indicator # -------------------------------------------------------------------- +---------- sub unlock() { my ($filfnm, @arglst) = @_; #DEBUG print "Process $$ is preparing to release"; # First check and see if we have ever had it locked. my $lckcnt = &getLockCount($filfnm); if ($lckcnt eq $NVRLCK) { # Nope. Slap da hand. return $RET_NEVERLOCKED; } # Then check and see if we have it locked now. if ($lckcnt <= 0) { # Nope. Slap da hand. return $RET_ALREADYUNLOCKED; } # Decrement the lock counter $lckcnt = &decrLockCount($filfnm); #DEBUG print "Process $$ new lock count is $lckcnt"; if ($lckcnt < 0) { # Impossible condition. Lock counter gone negative?? print "INTERNAL ERROR: Lock counter for '$filfnm' is '$lckcnt +'!!\n"; return $RET_NEGLOCKCNT; } # If it's our last lock, release it. if (!$lckcnt) { # It's our last lock. Release the lock token file. my $lckfnm = &_getLockFilename($filfnm); { # Must disable warnings and strict for this no warnings; no strict; close $Lckhan{$KEY_LCKHAN}{$filfnm}; } } #DEBUG print "Process $$ has released "; return $RET_SUCCESS; } # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= # ==================================================================== +========== # Internal Subroutines # ==================================================================== +========== # -------------------------------------------------------------------- +---------- # _getLockFilename($filfnm) - Returns the lock token filename for a gi +ven file. # $filfnm: The filename for whom the lock token will be generat +ed # Returns: The lock token filename for that file. # -------------------------------------------------------------------- +---------- sub _getLockFilename { my ($filfnm, @arglst) = @_; my $lckfnm = $filfnm . $DFT_LCKEXT; # Lock token filename return $lckfnm; } # -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-= +-=-=-=-=-= # -------------------------------------------------------------------- +---------- # Perl modules MUST return true # -------------------------------------------------------------------- +---------- 1; __END__ # -------------------------------------------------------------------- +---------- # Update History: # # SKM = Steven K. Mariner # # 23-Apr-2005 SKM Initial writing + v0.10a # 23-Apr-2005 SKM Passes fundamental unit tests + v0.10a # 24-Apr-2005 SKM First release + v1.00 # 24-Apr-2005 SKM Multiple locks are now stacked + v1.10 # # -------------------------------------------------------------------- +---------- # To Do: # # -------------------------------------------------------------------- +---------- # Immediate Bug List: # # -------------------------------------------------------------------- +----------
In reply to Re: Threads and output files (locking)
by marinersk
in thread Threads and output files (locking)
by Anonymous Monk
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |