http://qs1969.pair.com?node_id=198088
Category: Miscellaneous
Author/Contact Info /msg podmaster
Description: update: use File::FlockDir instead (i am).
File::DumbLock - dumb locking mechanism (lock if file not exist)

File::DumbLock implements the dumbest kind of "locking" mechanism known to man. It's voluntary, and it can backfire, but virtually every plaform suports it.

Every time you "obtain a lock", a semaphore is created (a lockfile). Every time you "release a lock", that semaphore is deleted (if possible). If the lockfile can't be deleted, you'll be warned, but you'll lose the 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();

You can download it at File-DumbLock-0.01.tar.gz sometime soon.

update: If you know of a module that already exists that does this, please /tell me.

I am also entertaining name suggestions: Lock::Dumb, Lock::Semaphore, Lock::Simple, File::SimpleLock ...

update: It appears i won't be changing the name. DON'T USE THIS CODE did make me chuckle heartily.

=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;
Replies are listed 'Best First'.
DON'T USE THIS CODE
by merlyn (Sage) on Sep 16, 2002 at 06:22 UTC
    Please don't use this code.

    Please don't give this code your ++ votes.

    This code has obvious holes. It is neither functional, nor necessary.

    There are ways of executing "atomic" test-and-set operations in every operating system, and this code does not use any of them. This code has windows of vulnerability. It's not a matter of whether or not you'll get burned, but when.

    Do not use this code.

    -- Randal L. Schwartz, Perl hacker


    UPDATE: Hey, to the losers who downvoted this node, next time you get broken in or you can't get your code to work, just remember what you think of expert advice. {sigh} If you don't want me watching your backside, I won't waste my time. I just wish you would have enough guts to tell me to my e-face. Not just -- this node.

    And a few people were kind enough to ask me to post references to how it should be done. Most of the first dozen hits I examined by a simple google for "perl lock" were very well written and don't suffer the problems of the code above. I don't think I should need to add instructions about google-ing to every node I write. {sigh}

      merlyn sez :

      I don't think I should need to add instructions about google-ing to every node I write. {sigh}
      Ah, but how would they know they were good examples in your opinion?

      I --ed you.

      I say in pod

      File::DumbLock implements the dumbest kind of "locking" mechanism known to man. It's voluntary, and it can backfire, but virtually every plaform suports it.

      Most of your comments fall apart in face of that statement.

      Flock is not supported on win9x.

      I think people are --ing you because you haven't offered any alternatives, and thus your statements sound smart-alecky.

      I certainly would like to know what

      ways of executing "atomic" test-and-set operations
      are for win9x.

      Are you talking about attempting to create a "lock directory" instead of a lock file (now that I think about it, that's what i'll change it to do)?

      I for one would like to know( i do say above: "If you know of a module that already exists that does this, please /tell me", did I have to also say if you know a better flockless way, tell me?)

      ____________________________________________________
      ** The Third rule of perl club is a statement of fact: pod is sexy.

        Look, your code breaks on every platform. It's dangerous. It will start to spread a bad meme to most of the other platforms, and we don't need that.

        You have not contributed anything to the art. You have only muddied the water.

        perlport says that flock works on Win2K. Hence, the solutions I wrote nearly seven years ago for Unix work fine on Win2K today. The only place this breaks down is on older win95 and win98 releases. For that, your solution offers nothing that works consistently, and even definitely fails because you are performing time-related operations in separate steps, and would be a step backwards for the community at large.

        You have not solved a thing with your post. You have only harmed the community. Thus, I stepped in to try to mark this code as bad as quick as I could.

        -- Randal L. Schwartz, Perl hacker

        One example strategy could be unlink: you try to delete something and check for the result. If you succeeded, you obtained the lock. This approach makes things more complicated for stale locks...

        Ciao, Valerio

        update: thanks podmaster for the hint.

      Well. I'm going to buck the trend and agree with merlyn.

      When I first read the node I assumed from the module name that it was mildly-subtle humour on poor locking strategies. Later posts seem to indicate this was not the intention.

      The code has many problems (e.g. not using atomic operations). It needed a warning. I'm glad merlyn made his post. I will ++ it when tomorrows votes roll in.

      That said - just one sentence on why the module was bad (maybe just a reference to 'perldoc -q lock') wouldn't have been too much effort would it :-)

      > I don't think I should need to add instructions about
      > google-ing to every node I write.

      So basically what you are saying is that you don't have to prove anything that you say cause all people have to do is type the right combination of words into google and browse around testing that code for a few hours to see the same thing?

      ()-()
       \"/
        `                                                     
      
        So basically what you are saying is that you don't have to prove anything that you say cause all people have to do is type the right combination of words into google and browse around testing that code for a few hours to see the same thing?
        No.

        But what would you rather I do with the limited time I have here...

        • Write one detailed treatise about why the code at the head of this thread is broken and dangerous?
        • Write five warning postings, leaving others to fill in the blanks if needed?
        I'd rather do the latter, because it innoculates five different diseases instead of just one. Of course, what I'd really rather do is...
        • Write two or three good real postings moving the community forward.
        But as long as people post crap like the beginning of this thread, I don't get to do that.

        It's fundamentally unethical of me to allow bad memes to stand, so as long as I see them, it's my responsibility to point them out. Now, as long as bad memes keep getting posted in this unmoderated forum, my destiny is predetermined. So, either moderate the forum, or let me post-moderate it as I have.

        -- Randal L. Schwartz, Perl hacker