The Perl Toolchain Summit 2025 Needs You: You can help 🙏 Learn more

#!/usr/bin/perl
# tlock
# Locking with timeouts.
# (c) 2022-2023 Bjrn Hee
# Licensed under the Apache License, version 2.0
use strict;
use experimental qw(signatures);
$| = 1;
use Getopt::Std qw(getopts);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
sub usage( $x ) { print STDERR q[
tlock [-<option> [parameter]] <command> [parameter ...]
Locking with timeouts.
Options:
-c <c> Use configuration file <c>. The other command line options overrule the
settings in the configuration file.
-d <d> Set lock directory to <d>.
-h Show help text.
-m <m> Set marker to <m>. Marker is the prefix that tlock names will have in
the file system.
-o <o> Set owner of the tlocks. Is silently ignored if the script user does
not have the necessary permissions.
-p <p> Set patience to <p>. Patience is the time that tlock will try to get a
lock that is already taken.
-V Show version.
Commands:
tlock take <label> <timeout>
Takes the specified tlock if possible. Prints the token value.
tlock renew <label> <token> <timeout>
Renews the tlock, so that it times out <timeout> seconds from the call of
this command.
tlock release <label> <token>
Releases the tlock.
tlock alive <label> <token>
Returns true if the specified tlock is still alive.
tlock taken <label>
Returns true if any tlock with the given label, is alive.
tlock expiry <label>
Prints the time when the tlock with the given label will expire.
tlock zing
Cleans up the lock directory.
] =~ s/^\s+/\n/r =~ s/\s+$/\n\n/r ; exit $x;};
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #
my $opt = {};
getopts('hVc:d:m:o:p:',$opt) or usage(1);
if ($opt->{h}) {
usage(0);
}
elsif ($opt->{V}) {
print 'tlock v'.$Sys::Tlock::VERSION."\n";
exit 0;
};
usage(1) if scalar @ARGV == 0;
my $cmd = shift @ARGV;
my %tropt = ();
$tropt{conf} = $opt->{c} if exists $opt->{c};
$tropt{dir} = $opt->{d} if exists $opt->{d};
$tropt{marker} = $opt->{m} if exists $opt->{m};
$tropt{owner} = $opt->{o} if exists $opt->{o};
$tropt{patience} = $opt->{p} if exists $opt->{p};
if ($cmd eq 'take') {
usage(1) if scalar @ARGV < 2;
usage(1) if scalar @ARGV > 3;
tlock_take(@ARGV,%tropt) || exit 1;
print $_."\n";
}
elsif ($cmd eq 'renew') {
usage(1) if scalar @ARGV != 3;
tlock_renew(@ARGV,%tropt) || exit 1;
}
elsif ($cmd eq 'release') {
usage(1) if scalar @ARGV != 2;
tlock_release(@ARGV,%tropt) || exit 1;
}
elsif ($cmd eq 'alive') {
usage(1) if scalar @ARGV != 2;
tlock_alive(@ARGV,%tropt) || exit 1;
}
elsif ($cmd eq 'taken') {
usage(1) if scalar @ARGV != 1;
tlock_taken(@ARGV,%tropt) || exit 1;
}
elsif ($cmd eq 'expiry') {
usage(1) if scalar @ARGV != 1;
my $expiry = tlock_expiry(@ARGV,%tropt);
exit 1 if not defined $expiry;
print $expiry."\n";
}
elsif ($cmd eq 'zing') {
usage(1) if scalar @ARGV != 0;
tlock_zing(%tropt);
}
else {
usage(1);
};
exit 0; # ------------------------------------------------------------------- #
__END__