179 lines
5.8 KiB
Perl
179 lines
5.8 KiB
Perl
# ==================================================================
|
|
# 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
|