view release on metacpan or  search on metacpan

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

our $VERSION = 1.11;

use File::Basename qw(basename dirname);
use Time::HiRes qw(gettimeofday sleep);
use Sys::Tlock::Config;

my sub qwac( $s ) {grep{/./} map{split /\s+/} map{s/#.*//r} split/\v+/ , $s;};

our @EXPORT = qwac '
    tlock_take     # Take the requested lock and give it the requested timeout, return a token.
    tlock_renew    # Set a new timeout, counting from now, for the given lock.
    tlock_release  # Remove the lock.
    tlock_alive    # True if the lock is still taken.
    tlock_taken    # True if the lock is taken, with any token.
    tlock_expiry   # Time when the lock expires.
    tlock_zing     # Clean up locks in the lock directory.
    ';

our @EXPORT_OK = qwac '
    tlock_release_careless # Remove the lock without caring about the token.
    tlock_token    # Token associated with lock.
    tlock_tstart   # Time when the lock was taken (= token).
    $dir           # The directory containing the locks.
    $marker        # The common prefix of the lock names.
    $owner         # The UID of the owner of the lock directories.
    $patience      # Max waiting time in seconds, when taking a lock that is already taken.
    ';

our $dir;
our $marker;
our $owner;
our $patience;
my $gid;

# --------------------------------------------------------------------------- #
# Initialization and import.

my $home = $Sys::Tlock::Config::home;

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #

my sub dir_check( $d ) {
    return undef if not defined $d;
    if (not -d $d) { warn 'The lock directory "'.$d.'" not found.'; return undef; };
    return ($d =~ s/(?<!\/)$/\//r);
    };


my sub marker_check( $m ) {
    return undef if not defined $m;
    if ($m !~ m/^[a-zA-Z]/) { warn 'Bad first character in marker.'; return undef; };
    if ($m !~ m/[a-zA-Z0-9]$/) { warn 'Bad last character in marker.'; return undef; };
    if ($m =~ m/[^a-zA-Z0-9\-\_]/) {warn 'Bad character in marker.'; return undef; };
    return $m;
    };


my sub owner_check( $o ) {
    return undef if not defined $o;
    return [-1,-1] if $o == -1;
    my $g = (getpwuid($o))[3];
    if (not defined $g) { warn 'Owner "'.$o.'" not found.'; return undef; };
    return [$o,$g];
    };


my sub patience_check( $p ) {
    return undef if not defined $p;
    if ($p !~ m/^\d+(\.\d+)?$/n) { warn 'Patience set to bad value "'.$p.'".'; return undef; };
    return $p;
    };

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #

my $memo = {};

my sub read_conf( $cf ) {
# Read and parse configuration file, return hashref with settings.

    return {} if not defined $cf;
    if (not -f $cf) {
        warn 'Could not find configuration file "'.$cf.'".';
        return undef;
        };

    return $memo->{$cf} if exists $memo->{$cf};

    my $setting = {};

    my $fh;
    if (open $fh , '<' , $cf) {;}
    else {
        warn 'Could not read configuration file "'.$cf.'".';
        return undef;
        };

    my $line = <$fh>;
    if ($line !~ m/^tlock\s+(\d+)\s*$/) {
        warn 'No tlock preface line in configuration file "'.$cf.'".';
        return undef;
        };
    if ($1 > 1) {
        warn 'Configuration file "'.$cf.'" is too new for your tlock installation.';
        return undef;
        };

    while ($line = <$fh>) {
        $line =~ s/#.*//;
        $line =~ s/\s+$//;
        if ($line =~ m/^\s*dir\s+(\S.*)$/) {
            $_ = dir_check($1);
            if (not defined) { $setting = undef; last; };
            $setting->{dir} = $_;
            }
        elsif ($line =~ m/^\s*marker\s+(\S.*)$/) {
            $_ = marker_check($1);
            if (not defined) { $setting = undef; last; };
            $setting->{marker} = $_;
            }
        elsif ($line =~ m/^\s*owner\s+(\d+|-1)$/) {
            $_ = owner_check($1);