################################################################################
#
#  kPerl Core Library Group
#  Library for Safe File Access Locking
#
#  copyright (c)
#    Karol Szafranski, 2005, 2007
#  author
#    Karol Szafranski, karol.szafranski@leibniz-fli.de
#
################################################################################
#
#  DESCRIPTION
#
# - purpose
#   provide an error-prone, file-based concept for unique access managment,
#   in situations where parallel processes may request access. The advantage
#   over concepts based on flock() is: it works.
#
# - individual description of functions at the beginning of the code blocks
#
################################################################################
#
#  FUNCTIONS, DATA
#
#   @EXPORT
#   %LibGlob
#   %_LibParam
#
# - physical object access and job control
#   $_LibParam{Mail*}
#   &PhysicalAccessCtrl
#
################################################################################

package MainLib::FileAccessLock;

# includes
use strict; #use warnings;  # OK 20050227
use FileHandle;

# symbol export
use Exporter qw(import);
our @EXPORT = qw (
  &filelock &fileunlock
  );

# package-wide constants and variables
our %LibGlob = (log=>0);
our %_LibParam;
  # `my %_LibParam;' would clash with same declaration in
  # package MainLib::FileAccessLock::sleeper


################################################################################
# lock procedure

$_LibParam{multiread} = 5;

# hammer on lock file to get private access to the target
#
# INTERFACE
# - argument 1: path of target
#               the control process will look for the file $target$suffix
#
# - options:
#   -debug      print debug protocol to STDOUT/STDERR
#   -func       code reference, arguments via -FuncArg
#   -FuncArg    arguments for function call, option -func
#   -log        switch on event logging to STDOUT
#   -mail       send mail messages to owner of the lock file (or value of
#               'address'). opt value is a hash reference:
#               from       (optional) address of the sender
#               ProcStamp  (optional) ID stamp of the process
#               subject    (optional) subject text
#               to         (optional) address of the recipient
#   -mode       action mode
#               wait   wait for lock-flag file to disappear and return
#                      (default mode)
#               func   wait for unlock status and if unlocked set the
#                      lock-flag file by ourselves and call a function
#                      referenced by option -func. The return value will be
#                      the final operation status.
#   -noLock     don't create a lock file. The called process (mode 'func')
#               is assumed to create the appropriate lock-flag file.
#   -suffix     file suffix that flags locking, default: ".BUSY"
#
# - return val: - return value of called function, which should be a 
#                 boolean value reflecting success status
#               - operation status (boolean) for option -wait
#               - undef if an error occurs
#
# DESCRIPTION
# - the argument of this function is the target file, not the lock file (which
#   is the only file that is physically dealt with, here). The motivation for
#   this interface design is to hide the actual identity from the caller, in
#   order to keep a stable correspondence between target file and lock file.
#   This correspondence is only loosened if the caller explicitly requests it,
#   e.g. via option -suffix.
# - a unique lock file reflects the lock status of the target file. It
#   contains the pid of the process that currently has private access to the
#   target file.
#
sub filelock {
  my ($file,%opt) = @_;
  my $debug = $LibGlob{log};
  my $flock = $file . ($opt{-suffix}||'.lock');
  my $pSleep = $opt{-sleep} ||= MainLib::FileAccessLock::sleeper->new();

  # check if lock file exists => overlap with another request client
  # extra check if file lock is owned by me (shouldn't happen but seems to do; 20070208)
  if (-e $flock and _lockfile_read($flock) ne "$$ success") {
    $pSleep->sleep();

    # check lock file for validity
    my $bValid=1;
    if (-e $flock) {
      my $l=_lockfile_read($flock);
      if ($l!~m/^(\w+:)?\d+ success$/) {
        my $l2;
        for (1 .. ($_LibParam{multiread}+2)) { $l2=_lockfile_read($flock) }
        if ($l2 eq $l) { $bValid=0 }
      }

      # valid lock (by another client), retry via recursion
      if ($bValid) {
        return &filelock($file,%opt);
      }

      # lock invalid
      else {
        $debug and printf STDERR "%s. removing invalid lock: %s\n", (caller(0))[3], $l;
        unlink $flock;
      }
    }

    # lock disappeared? Continue trial to get lock
  }

  # try to get lock
  { my $hw=FileHandle->new($flock,'w');
    print $hw $$;
  }
  if (_lockfile_read($flock) ne $$) { return &filelock($file,%opt) }
  { my $hw=FileHandle->new($flock,'a');
    print $hw " success\n";
  }
  my $chk; for (1 .. $_LibParam{multiread}) { $chk=_lockfile_read($flock) }
  if ($chk ne "$$ success") { return &filelock($file,%opt) }
  $debug and printf STDERR "%s. achieved stable lock, pid %d\n", (caller(0))[3], $$;

  # success!!!
  return 1;
}


sub fileunlock {
  my ($file,%opt) = @_;
  my $flock = $file . ($opt{-suffix}||'.lock');
  unlink $flock;
  return ! -e $flock;
}


sub _lockfile_read {
  my ($flock) = @_;
  my $h=FileHandle->new($flock,'r');
  my $line; while(<$h>) { chomp; if(length($_)){ $line=$_ } }
  return $line;
}


################################################################################
# randomized sleeping, with increasing time amount

package MainLib::FileAccessLock::sleeper;

# package-wide constants and variables
our %LibGlob = (log=>0);
my %_LibParam;

# shall we really re-initialize the random number generator?
# default: don't
$LibGlob{rand_init_done} = 1;

# waiting time constant for &_init, calibrated to a time amount of about 50 ms
$_LibParam{sleep_dur} = 100000;
$_LibParam{sleep_min} = 0.33;
$_LibParam{sleep_progr} = 1.33;


# object initializer
$_LibParam{init} = {
  tnight => $_LibParam{sleep_dur},
  tslept => 0.00,
  uslept => 0.00,
  };

sub new {
  if (! $LibGlob{rand_init_done}) { _init() }
  bless { %{$_LibParam{init}} };
}

# initialize random number generator
# - randomized here also includes near-parallel calls from the command line
# - this is not a method!
sub _init {
  srand (11*int((time()^($$+($$<<15)))/11));
  $LibGlob{rand_init_done} = 1;
  _init_progress (int(2*rand()) & 1);
  return 1;
}

# proceed initialization of random number generator
# - this is not a method!
sub _init_progress {
  my $bAdd=shift;
  srand(int(rand()*$_LibParam{sleep_dur})*2-$bAdd)
}


# wait for a randomized amount of time
# - eventually, debug to STDERR
sub sleep {
  my $this=shift;
  my $ts = (times)[0];
  my $tu = $_LibParam{sleep_min}*$this->{tnight}
    + int (rand() * (1-$_LibParam{sleep_min})*$this->{tnight});
  my $sTmp=''; for(0..$tu){ $sTmp.=' ' }
  if ($LibGlob{log}) {
    printf STDERR "%s. waited %s units, %s s\n", (caller(0))[3], $tu, (times)[0]-$ts;
  }
  $this->{tslept} += $ts;
  $this->{uslept} += $tu;
  $this->{tnight} *= $_LibParam{sleep_progr};
  return length($sTmp);
}

1;
# $Id: FileAccessLock.pm,v 1.5 2018/06/05 18:02:56 szafrans Exp $
