Atomic non-blocking advisory lock on NFS using hard links

gistfile1.pl

sub do_something {
    my $path = shift;
 
    # Skip this if another server is already working on it
    return unless my $lock = LinkLock->lock($path);
 
    my $users = Get_arrayref_from_database();

    open my $fh, '>', $path;
    print $fh join( ':', @$_ ), "\n" for @$users;
    close $fh;
}
 
package LinkLock;
 
# From "man open":
 
# O_EXCL is broken on NFS file systems; programs which rely on it for
# performing locking tasks will contain a race condition.  The solution
# for performing atomic file locking using a lockfile is to create a
# unique file on the same file system (e.g., incorporating hostname
# and pid), use link(2) to make a link to the lockfile. If link()
# returns 0, the lock is successful.  Otherwise, use stat(2) on the
# unique file to check if its link count has increased to 2, in which
# case the lock is also successful.
 
sub lock {
    my ($class, $file) = @_;

    my $lock = join '.', $file, $$, int rand 1e8;
    open my $fh, '>', $lock or die "Couldn't open lock file $lock: $!";
    print $fh $$;
    close $fh or die "Couldn't close lock file $lock: $!";
    my $link = "$file.lock";
    unlink $lock and return unless link $lock, $link or ( stat($lock) )[3] == 2;
    return bless [ $lock, $link ], $class;
}
 
sub DESTROY { unlink @{shift()} }