=head1 NAME
File::DumbLock - dumb locking mechanism (lock if file not exist)
=head1 SYNOPSIS
#!/usr/bin/perl
use strict;
eval q{use warnings}; #use warnings if u got 'em
use File::DumbLock;
my $file = 'filename'; # doesn't exist, but it doesn't matter
my %Dumb = (
name => $file, # required
retry => 2, # default is 5
sleep => .1, # also the default
wait => 2 * 60, # also the default
);
my $dumB = new File::DumbLock(\%Dumb);
my $dumC = new File::DumbLock(%Dumb);
# creates $file.dumblock
# select undef,undef,undef, $sleep; until it can, or it times out
if( $dumB->Open() ){
warn " dumB got lock";
warn " dumC don't got lock " unless $dumC->Open();
open(FOY,'>'.$file) or die "can't open $file $!";
print FOY 'foy';
close(FOY);
warn "closing dumB ".$dumB->Close();
}
warn " dumC got lock" if $dumC->Open();
$dumC->Close();
=head1 DESCRIPTION
File::DumbLock implements the dumbest kind of "locking" mechanism know
+n to man.
It's voluntary, and it can backfire, but virtually every plaform supor
+ts it.
Every time you "obtain a lock", a semaphore is created (a lockfile).
Every time you "release a lock", that semaphore is deleted (if possibl
+e).
If the lockfile can't be deleted, you'll be warned, but you'll lose th
+e lock.
Example:
my $dumB = new File::DumbLock(name => 'file' );
my $dumC = new File::DumbLock(name => 'file', wait => 2 );
print "dumB got lock\n" if $dumB->Open();
sleep 2;
print "dumC stole lock\n" if $dumC->Open();
print "dumB couldn't get lock\n" unless $dumB->Open();
=head1 METHODS
=head2 new
The constructor, a class method.
Takes either a hashref, or a list of key value pairs (and they must be
+ pairs).
=over 4
=item name
The filename, a required argument.
=item retry
The number of times to attempt to obtain a lock (default is 5).
=item sleep
The number of seconds to sleep for (default is .1).
=item wait
If the lockfile is older than the wait(in seconds),
while you're trying to obtain a lock (Open),
you'll get it.
=back
=head2 Open
An object method.
When invoked, attempts to obtain a lock.
Returns a true value upon success, or if it already has a lock,
and a false value upon failure.
If the lockfile doesn't exist, creates it (obtains a lock).
If the lockfile exists, checks if its is expired.
It does this 'retry' number of times,
sleeping 'sleep' amount of seconds in between.
=head2 Close
An object method.
When invoked, releases a lock. Always returns a true value.
Attempts to unlink the lockfile, and warns you if it can't.
=head1 AUTHOR
D. H. aka podmaster (see CPAN)
=cut
package File::DumbLock;
use 5.00000;
use strict;
use vars qw($VERSION);
use Carp qw( carp croak );
$VERSION = '0.01';
my %DEF = (
retry => [ 5, '^\d+\z' ],
sleep => [ .1, '^\d+?(?:\.\d+)?\z'],
wait => [ 60 * 10, '^\d+\z' ],
);
sub new {
my( $class, $o ) = @_;
$o = {$o, @_ } if @_ > 2;
croak "The name argument is required" unless exists $o->{name};
for my $key(keys %DEF) {
if( exists $o->{$key} ) {
unless( $o->{$key} =~ m{$DEF{$key}->[1]} ) {
carp "Argument $key needs to match qr{"
.$DEF{$key}->[1].'\}. '
."Assuming default($DEF{$key}->[0])";
}
} else {
$o->{$key} = $DEF{$key}->[0];
}
}
$o->{filo} = $o->{name}.'.dumblock';
return bless $o, $class;
}
sub _exists_and_young {
my $self = shift;
my @stat = stat $self->{filo};
return() unless @stat;
return $self->{wait} > time - $stat[9]; # young if wait > age
}
sub _have_lock {
my $self = shift;
my @stat = stat $self->{filo};
return() unless @stat;
return $stat[9] == $self->{ctime};
}
sub Open {
my $self = shift;
return 1 if $self->_have_lock;
my $filo = $self->{filo};
for(1 .. $self->{retry}){
if( $self->_exists_and_young ) {
select undef, undef, undef, $self->{sleep};
} else {
umask 0000; # just in case
open(FILO, '>'.$filo ) or croak "couldn't create $filo $!"
+;
$self->{ctime} = time;
chmod( 0777, $filo ) or croak "couldn't chmod $filo 0777 (
+$!)";
close(FILO);
return 1; # E00000 0 ;)
}
}
return(); # we failed
}
sub Close {
my $self = shift;
my $filo = $self->{filo};
delete $self->{ctime};
unlink($filo) or carp "couldn't unlink $filo ($!)";
return(1); # success
}
sub DESTROY {
my $self = shift;
$self->Close() if -e $self->{filo};
undef $self;
}
1;
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.