in reply to Threads and output files (locking)

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:
#
# --------------------------------------------------------------------
+----------

[download]

Replies are listed 'Best First'.
Re^2: Threads and output files (locking)
by marinersk (Priest) on May 15, 2011 at 05:26 UTC

    And here's a little test program you can use to ensure the locking itself is working properly. It's a heavily watered-down variant of the unit test program, but it seems to work.

    You can run it in two windows simultaneously and see how the locking interacts.

    You can also run the second copy with a "2" as its parameter, and it tests the first two files in reverse order. Not sure I remember why that seemed important at the time LOL. Examples: 

    $ filelock-sample.pl
$ filelock-sample.pl 2


    #!/usr/bin/perl

# --------------------------------------------------------------------
+----------
# filelock-sample - Show basic filelock.pm usage
# --------------------------------------------------------------------
+----------

use strict;

# --------------------------------------------------------------------
+----------
# Modules we use
# --------------------------------------------------------------------
+----------

use filelock;


# --------------------------------------------------------------------
+----------
# Constants (operationally, if not technically)
# --------------------------------------------------------------------
+----------

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
+-=-=-=-=-=

my    $RET_SUCCESS    = 0;                # Return value for success
my    $RET_FAILURE    = 1;                # Return value for general f
+ailure
my    $RET_FATAL        = (-1);                # Return value for fata
+l failure

my    $TRUE    = 1;
my    $FALSE    = 0;

my    $PAUTIM    = 10;                        # Pause time for testing

my $LCKFN1 = 'filelock-test1.dat';
my $LCKFN2 = 'filelock-test2.dat';
my $LCKFN3 = 'filelock-test3.dat';

my    $TLGFNM = 'filelock.testlog';        # Unit test logfile name
my    $TL2FNM = 'filelock2.testlog';        # Unit test logfile name f
+or 2nd copy


# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
+-=-=-=-=-=


# --------------------------------------------------------------------
+----------
# Globals
# --------------------------------------------------------------------
+----------

my    $Fatflg;                            # Fatal operation flag (end 
+program ASAP)
my    $Wrkflg;                            # Did we ever do any work?
my    $Tstflg = $FALSE;                    # Are we in unit test mode?
my    $Fstflg = $FALSE;                    # Do we do the tests the fa
+st way?

my    $Tstfn1 = $LCKFN1;
my    $Tstfn2 = $LCKFN2;
my    $Tstfn3 = $LCKFN3;

my    $Tlgfnm = $TLGFNM;

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
+-=-=-=-=-=


# --------------------------------------------------------------------
+----------
# Go Forth and Conquer.  No, wait -- that should be "Go Perl and Conqu
+er"
# --------------------------------------------------------------------
+----------

    # ----------------------------------------------------------------
+----------
    # Sorry this is so crude; I ripped it out of the unit test for thi
+s module.
    # ----------------------------------------------------------------
+----------

eval {
    foreach my $curpar (@ARGV)
    {
        if ($curpar =~ /^\-/)
        {
            # Command line switch
            if ($curpar =~ /^\-fast/i)
            {
                # FAST mode
                $Fstflg = $TRUE;
            }
            else
            {
                # Invalid option
                &usage();
                print "Invalid option '$curpar'\n";
            }
        }
        else
        {
            # Regular parameter
            $Wrkflg = 1;    # Yes, we've actually asked for real work 
+to be done
            my $retval = &filelocktest($curpar);
            if ($Fatflg)
            {
                return $retval;
            }
        }
    }

    # Check if there was ever a valid parameter
    if (!$Wrkflg)
    {
        # Nope.  Handle the "no valid parameter" condition.
        # Parameter is not required
        my $retval = &filelocktest();
        if ($Fatflg)
        {
            return $retval;
        }
    }
} ; # End eval{} error trap set REQUIRES a semicolon

if ($@)
{
    my $dsperr = $@;
    print "$dsperr";
}

exit;

# ====================================================================
+==========
# Subroutines
# ====================================================================
+==========


# --------------------------------------------------------------------
+----------
# filelocktest($curpar) - Unit test for the filelock module
# --------------------------------------------------------------------
+----------

sub filelocktest
{
    my ($curpar, @arglst) = @_;

    if ($curpar eq "2")
    {
        # User has indicated this is the second locking test

        # I cannot remember the scalar swap command name. Do it the ha
+rd way.
        my $tmpfn1 = $Tstfn1;
        $Tstfn1 = $Tstfn2;
        $Tstfn2 = $tmpfn1;
        # Change testing logfile name
        $Tlgfnm = $TL2FNM;
    }
    &test($curpar);

}


# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
+-=-=-=-=-=


# --------------------------------------------------------------------
+----------
# test($curpar) - Perform unit testing.
#
#     $curpar:    The parameter passed in from filelocktest() - if "2"
+ I'm 2nd copy.
#     Returns:  Nothing
# --------------------------------------------------------------------
+----------

sub test
{
    my ($curpar, @arglst) = @_;

    # ----------------------------------------------------------------
+----------
    {
        print "TEST:  lock() works\n";

        my $EXPTST = $TRUE;

        my $dspret = '';

        print "Process $$ locking $Tstfn1\n";
        my $lckret = &filelock::lock($Tstfn1);
        print "Process $$ finished locking $Tstfn1\n";
        $dspret .= "lock #1 '$lckret'  ";
        if ($lckret ne $filelock::RET_SUCCESS)
        {
            # Failed in a detectable way.
            print "FAIL!\n";
        }
        else
        {
            # Seems to have worked.  Sleep awhile, lock #2.
            if (!$Fstflg)
            {
                print "Process $$ sleeping $PAUTIM seconds\n";
                sleep $PAUTIM;
            }

            print "Process $$ unlocking $Tstfn1\n";
            my $secret = &filelock::unlock($Tstfn1);
            print "Process $$ finished unlocking $Tstfn1\n";

            print "Process $$ locking $Tstfn2\n";
            my $secret = &filelock::lock($Tstfn2);
            print "Process $$ finished locking $Tstfn2\n";
            $dspret .= "lock #2 '$secret'  ";
            if ($secret ne $filelock::RET_SUCCESS)
            {
                # Failed in a detectable way.
                print "FAIL!\n";
            }
            else
            {
                # Seems to have worked.  1st Sleeps awhile.  Both lock
+ #3.
                if ($curpar ne "2")
                {
                    if (!$Fstflg)
                    {
                        print "Process $$ sleeping $PAUTIM seconds\n";
                        sleep $PAUTIM;
                    }
                }

                print "Process $$ locking $Tstfn3\n";
                my $secret = &filelock::lock($Tstfn3);
                print "Process $$ finished locking $Tstfn3\n";
                $dspret .= "lock #3 '$secret'  ";
                if ($secret ne $filelock::RET_SUCCESS)
                {
                    # Failed in a detectable way.
                    print "FAIL!\n";
                }
                else
                {
                    # Seems to have worked.  Sleep awhile, unlock.

                    if (!$Fstflg)
                    {
                        print "Process $$ sleeping $PAUTIM seconds\n";
                        sleep $PAUTIM;
                    }

                    print "Process $$ unlocking $Tstfn2\n";
                    my $secret = &filelock::unlock($Tstfn2);
                    print "Process $$ finished unlocking $Tstfn2\n";

                    if (!$Fstflg)
                    {
                        print "Process $$ sleeping $PAUTIM seconds\n";
                        sleep $PAUTIM;
                    }

                    print "Process $$ unlocking $Tstfn3\n";
                    my $secret = &filelock::unlock($Tstfn3);
                    print "Process $$ finished unlocking $Tstfn3\n";
                }
            }
        }
        $dspret =~ s/^\s+//;
        $dspret =~ s/\s+$//;

        print "RESULTS:  $dspret\n";
    }

    # ----------------------------------------------------------------
+----------
    {
        print "TEST:  duplicate locks stack properly\n";

        my $EXPTST = $TRUE;
        my $EXPCNT = 2;
        my $EXPCN2 = 1;
        my $EXPCN3 = 0;

        my $dspret = '';

        #print "DEBUG:  First lock...\n";
        my $lckret = &filelock::lock($Tstfn1);
        $dspret .= $lckret;
        if ($lckret ne $filelock::RET_SUCCESS)
        {
            # Failed in a detectable way.
            print "FAIL!\n";
        }
        else
        {
            # Seems to have worked.  Lock it again.
            #print "DEBUG:  First lock succeeded...Second lock...\n";
            my $secret = &filelock::lock($Tstfn1);
            $dspret .= "/$secret";
            if ($secret ne $filelock::RET_SUCCESS)
            {
                # Failed in a detectable way.
                print "FAIL!\n";
            }
            else
            {
                # Both worked.  Check lock depth.
                #print "DEBUG:  Second lock succeeded...Checking lock 
+depth...\n";
                my $lckdep = &filelock::getLockCount($Tstfn1);
                $dspret .= "/$lckdep";
                if ($lckdep ne $EXPCNT)
                {
                    # Lock depth is not what was expected.
                    print "FAIL!\n";
                }
                else
                {
                    # Right depth.  Release locks.
                    #print "DEBUG:  Unlock second lock...\n";
                    my $unlret = &filelock::unlock($Tstfn1);
                    $dspret .= "/$unlret";
                    my $unldep = &filelock::getLockCount($Tstfn1);
                    if ($unldep ne $EXPCN2)
                    {
                        # Lock depth did not downwardly adjust properl
+y.
                        print "FAIL!\n";
                    }
                    else
                    {
                        # One more unlock to go.
                        #print "DEBUG:  Unlock successful...unlock fir
+st lock...\n";
                        my $un2ret = &filelock::unlock($Tstfn1);
                        $dspret .= "/$un2ret";
                        my $un2dep = &filelock::getLockCount($Tstfn1);
                        if ($un2dep ne $EXPCN3)
                        {
                            # Lock depth did not downwardly adjust pro
+perly.
                            print "FAIL!\n";
                        }
                        else
                        {
                            # Goodness, we're done!
                            #print "DEBUG:  Unlock successful...Done w
+ith this test.\n";
                        }
                    }
                }
            }
        }

        print "RESULTS:  $dspret\n";
    }

    # ----------------------------------------------------------------
+----------
}

    [download]

[reply]
[d/l]

In Section Seekers of Perl Wisdom