Perl flock: prevent multiple invocation based on variable-CodePudding

I would like to prevent multiple invocation of a Perl script based on a variable or command-line arguments. Extending this answer:

#!/usr/bin/env perl

use strict;
use warnings;

use Getopt::Long;
my ( $foo, $bar );
GetOptions (
    "foo" => \$foo,
    "bar" => \$bar,
    ) || die "usage: $0 [ -foo | -bar ]\n";

use Fcntl ':flock';
flock(DATA, LOCK_EX|LOCK_NB) or die "There can be only one! [$0]";

say STDOUT (($foo?"foo":$bar?"bar":"nobody")." sleeps");
sleep(2);

# mandatory, flocking depends on DATA file handle
__DATA__

How can I lock app.pl -foo and app.pl -bar independently?

CodePudding user response：

This is what I've come up so far. Kindly suggest if there's a better answer:

#!/usr/bin/env perl

use strict;
use warnings;

$SIG{HUP}=\&sigHandler;  # 1
$SIG{INT}=\&sigHandler;  # 2
$SIG{QUIT}=\&sigHandler; # 3
$SIG{KILL}=\&sigHandler; # 9 - CANNOT BE CAUGHT
$SIG{TERM}=\&sigHandler; # 15
$SIG{STOP}=\&sigHandler; # 17 - CANNOT BE CAUGHT

use Getopt::Long;
my ( $foo, $bar );
GetOptions (
    "foo" => \$foo,
    "bar" => \$bar,
    ) || die "usage: $0 [ -foo | -bar ]\n";


use Fcntl qw(:flock);

sub lock {
    my ($fh) = @_;
    flock($fh, LOCK_EX|LOCK_NB) or die "There can only be one! [$0]: $!\n";
}

sub unlock {
    my ($fh) = @_;
    flock($fh, LOCK_UN) or die "Cannot unlock file - $!\n";
}

my $file = "$ENV{'HOME'}/".($foo?"foo":$bar?"bar":"nobody");
open(my $fh, '>', $file) or die "Can't open $file: $!";

sub sigHandler {
    say STDERR "$0: Program interrupted by '@_'. Terminating...";
    unlink ($file);
    unlock ($fh);
    exit 1;
}

lock ($fh);
say STDOUT (($foo?"foo":$bar?"bar":"nobody")." sleeps");
sleep(5);
unlink ($file);
unlock ($fh);
exit 0;

CodePudding user response：

I added a singleton() method to IPC::Shareable that does this using shared memory. Here's a simple example. It uses the argument sent into the script as the 'glue' to lock the script run.

use warnings;
use strict;

use IPC::Shareable;

die "Need arg" if ! @ARGV;

my $arg = $ARGV[0];

my $lock = $arg;
my $warn = 1;

IPC::Shareable->singleton($lock, $warn);

for (1..10) {
    print "$_\n";
    sleep 1;
}

Running perl script.pl foo will lock with foo. If you run the command again while the first instance is still running, you'll get Process ID 1105497 exited due to exclusive shared memory collision. If you run it with perl script.pl bar, it'll succeed.

It'd be wise to use a lock glue string more complex than just the argument (perhaps the name of the script concatenated with the argument value), but I digress.

I also wrote Script::Singleton which locks out any second instance of a script from being run, but it's implemented at compile time, so it can't decipher based on argument. It's script-level only.