discourse-legacysite-perl/site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm

# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Lock
#   Author: Scott Beck
#   CVS Info : 087,071,086,086,085      
#   $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: a small autonomous locking module.
#
package GT::Lock;

use vars qw/@EXPORT_OK $error $SAFETY $ERRORS/;
use strict;
use bases
    'Exporter' => '',
    'GT::Base' => '';

use constants
    MASK       => 0777,
    SLEEPTIME  => 0.05,
    TIMEOUT    => 10,
    LOCK_TRY   => 1,
    LOCK_FORCE => 2;

use POSIX qw/errno_h/;
use GT::TempFile;

$ERRORS = {
    'TIMEOUT' => 'Could not lock %s; We timed out',
    'NOLOCK'  => 'No lock was found for name %s'
};
@EXPORT_OK = qw/lock unlock LOCK_FORCE LOCK_TRY/;

sub lock {
#---------------------------------------------------------------------------------
    defined( $_[0] ) or GT::Lock->fatal( BADARGS => 'First argument must be a defined value' );
    my $name       = escape($_[0]);
    my $timeout    = defined $_[1] ? $_[1] : TIMEOUT;
    my $opt        = defined $_[2] ? $_[2] : LOCK_FORCE;
    my $max_age    = $_[3];
    my $tmp_dir    = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir();
    my $lock_dir   = "$tmp_dir/$name";
    if ($max_age and -d $lock_dir and time - (stat $lock_dir)[9] > $max_age) {
        rmdir $lock_dir or $! == ENOENT or GT::Lock->fatal(RMDIR => $lock_dir, "$!");
    }
    my $start_time = time;
    until (mkdir $lock_dir, MASK) {
        select undef, undef, undef, SLEEPTIME;
        if ($timeout and $start_time + $timeout < time) {
            if ($opt == LOCK_TRY) {
                return GT::Lock->warn(TIMEOUT => unescape($name));
            }
            else {
                # XXX - 2 appears to be No such file or directory, but may not be entirely portable.
                unless (rmdir $lock_dir and $! != ENOENT) {
                    # The rmdir failed which *may* be due to two processes
                    # holding the same lock then the other one deleting it
                    # just before this one attempted to.  In such a case, we
                    # allow double the timeout to try to avoid the race -
                    # though this reduces the frequency of race conditions, it
                    # does not completely eliminate it.
                    if ($timeout and $start_time + 2 * $timeout < time) {
                        GT::Lock->fatal(RMDIR => $lock_dir, "$!");
                    }
                }
            }
        }
    }
    return 1;
}

sub unlock {
#--------------------------------------------------------------------------------
    my $name     = escape($_[0]);
    my $tmp_dir  = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir();
    my $lock_dir = "$tmp_dir/$name";
    if (-d $lock_dir) {
        rmdir $lock_dir or return GT::Lock->fatal(RMDIR => $lock_dir, "$!");
    }
    else {
        return GT::Lock->warn(NOLOCK => $name);
    }
    return 1;
}

sub escape {
#--------------------------------------------------------------------------------
    my $toencode = $_[0];
    return unless (defined $toencode);
    $toencode    =~ s/([^\w. -])/sprintf "%%%02X", ord $1/eg;
    $toencode    =~ s/ /%20/g;
    return $toencode;
}

sub unescape {
#--------------------------------------------------------------------------------
    my $todecode = $_[0];
    return unless (defined $todecode);
    $todecode    =~ tr/+/ /;       # pluses become spaces
    $todecode    =~ s/%([0-9a-fA-F]{2})/chr hex $1/ge;
    return $todecode;
}

1;

__END__

=head1 NAME

GT::Lock - a small autonomous locking module.

=head2 SYNOPSIS

    use GT::Lock qw/lock unlock LOCK_TRY LOCK_FORCE/;

    # attempt to lock foobar for 10 seconds
    if (lock 'foobar', 10, LOCK_TRY) {
        # do some code that needs to be locked
        unlock 'foobar';
    }
    else {
        # oops out lock failed
        die "Lock failed: $GT::Lock::error\n";
    }

=head1 DESCRIPTION

GT::Lock is a very simple module to impliment autonomous named locking. Locking
can be used for many things but is most commonly used to lock files for IO to
them.

Nothing is exported by default. You may request the lock, unlock routines be
exported. You can also get the two constants for lock types exported:
C<LOCK_TRY> and C<LOCK_FORCE>.

=head2 lock - Lock a name.

    lock NAME [, TIMOUT, TYPE, AGE ]

This method is used to create a lock.  Its arguments are the name you wish to
give the lock, the timeout in seconds for the lock to happen, the type of lock,
and the maximum lock age (in seconds).  The types are C<LOCK_FORCE> and
C<LOCK_TRY>.  If C<LOCK_FORCE> is given a lock always succeeds, e.g. if the
lock times out the lock is removed and your lock succeeds.  Try attempts to get
the lock and returns false if the lock can not be had in the specified
C<TIMEOUT>.  If C<TIMEOUT> is zero this method will attempt to lock forever.
C<TIMEOUT> defaults to 10 seconds.  The AGE parameter can be used to ensure
that stale locks are not preserved - if the lock already exists and is older
than AGE seconds, it will be removed before attempting to get the lock.
Omitting it uses the default value, undef, which does not attempt to remove
stale locks.

=head2 unlock - unlock a name.

    unlock NAME

This method is used to unlock a name. It's argument is the name of the lock to
unlock. Returns true on success and false on errors and sets the error in
$GT::Lock::error.

=head1 DEPENDANCIES

L<GT::Lock> depends on L<GT::TempFile>, L<bases>, and L<constants>.

=head1 COPYRIGHT

Copyright (c) 2005 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $

=cut