view release on metacpan or  search on metacpan

lib/Sys/Tlock.pm  view on Meta::CPAN

# They are for making changes on tlocks atomic.
# 
# Some background info:
#     https://rcrowley.org/2010/01/06/things-unix-can-do-atomically.html

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
# Helper routines.

my sub tdn( $label , $d , $m ) {
# The tlock directory name.
    return $d.$m.'.'.$label;
    };


my sub take_master( $label , $d , $m , $p ) {
# Master lock has to be taken for any operation on the lock.

    my $now = gettimeofday;

    while (1)
      { my $rv = mkdir $d.$m.'_.'.$label;
        last if $rv == 1; # second order success
        return if gettimeofday - $now > $p;
        sleep(0.05);
      };

    1;};


my sub release_master( $label , $d , $m ) {
    rmdir $d.$m.'_.'.$label;
    1;};

# --------------------------------------------------------------------------- #
# Exportable routines.

sub tlock_take( $label , $timeout , @nampar ) {
# Take the requested lock and give it the requested timeout, return token.

    return if $label !~ m/^[a-zA-Z0-9\-\_\.]+$/;
    return if $timeout <= 0;
    my $n;
    if (scalar @nampar == 1) { # For backwards compatability. Will be removed.
        $n = {patience => $nampar[0]};
        warn 'The optional patience parameter in tlock_take is deprecated. Use a named parameter instead.';
        }
    else {
        $n = {@nampar};
        };
    my $d = dir($n);
    my $m = marker($n);
    my ($o,$g) = owner($n)->@*;
    my $p = patience($n);

    take_master($label,$d,$m,$p) or return;

    my $t;
    if ( not tlock_taken($label,$n->%*) ) {
        my $tdn = tdn($label,$d,$m);
        mkdir $tdn if not -e $tdn;
        chown $o , $g , $tdn;
        mkdir $tdn.'/d' if not -e $tdn.'/d';
        chown $o , $g , $tdn.'/d';
        $t = int time;
        utime undef , $t , $tdn;
        utime undef , $timeout , $tdn.'/d';
        };

    release_master($label,$d,$m);
    $_ = $t; return $_;
    }; # sub tlock_take


sub tlock_renew( $label , $token , $timeout , %nampar ) {
# Set a new timeout, counting from now, for the given lock.
    return if $timeout <= 0;
    my $n = {%nampar};
    my $d = dir($n);
    my $m = marker($n);
    my $p = patience($n);
    take_master($label,$d,$m,$p) or return;
    utime undef , int(time) - $token + $timeout , tdn($label,$d,$m).'/d'
      if tlock_alive($label,$token,%nampar);
    release_master($label,$d,$m);
    return 1;
    };


sub tlock_release( $label , $token , %nampar ) {
# Remove the lock.
    my $n = {%nampar};
    my $d = dir($n);
    my $m = marker($n);
    my $p = patience($n);
    take_master($label,$d,$m,$p) or return;
    my $t = tlock_token($label,%nampar);
    if ($token == $t) {
        my $tdn = tdn($label,$d,$m);
        rmdir $tdn.'/d' if -e $tdn.'/d';
        rmdir $tdn      if -e $tdn;
        };
    release_master($label,$d,$m);
    return 1;
    };


sub tlock_alive( $label , $token , %nampar ) {
# True if the lock with the given token is still taken.
    my $t = tlock_token($label,%nampar);
    return if not defined $t;
    return 1 if $token == $t;
    return;
    };


sub tlock_taken( $label , %nampar ) {
# True if the lock is taken.
    return if not defined tlock_expiry($label,%nampar);
    return 1;
  };


sub tlock_expiry( $label , %nampar ) {