Perl CLI-app template

#!/usr/bin/perl
# perl cli-app template
# Copyright (C) Eskild Hustvedt 2025
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice (including the next
# paragraph) shall be included in all copies or substantial portions of the
# Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

# Note: you are encouraged to relicense this under a free software license,
# like GNU GPL v3 or similar.
#
# Make sure you replace all instances of the string perl-cli-app-template

use 5.020;
use feature 'signatures';
no warnings 'experimental::signatures';
use open qw(:utf8);
use Getopt::Long;
use File::Basename qw(basename);

#use Module::Load::Conditional qw(can_load);

my $verbosity = 0;

# Reads a file into a scalar and returns it
sub slurp($file) {
    open( my $in, '<', $file ) or die("Failed to open $file for reading: $!");
    local $/ = undef;
    my $content = <$in>;
    close($in);
    return $content;
}

# Writes a scalar to a file, dies on failure, returns the filename provided
# otherwise.
sub spurt( $file, $content ) {
    die("$file: is a directory")   if -d $file;
    die("$file: is not writeable") if -e $file && !-w $file;
    open( my $out, '>', $file ) or die("Failed to open $file for writing: $!");
    print {$out} $content;
    close($out) or warn("Warning: Failed to close the filehandle for $file\n");
    return $file;
}

# A *very simple* lockfile implementation
# This is very naive, and doesn't use any locking primitives from the OS, so there
# is a theoretical chance for a race condition, but for our purposes this is more than
# sufficient.
#
# It does not remove the lockfile on exit, but will verify that the PID actually belongs
# to perl-cli-app-template before deiciding that we're locked.
sub lockOrDie () {
    my $storeLocksIn = '/dev/shm';

    # If we're not on Linux, fall back to using /tmp
    if ( $^O ne 'linux' ) {
        $storeLocksIn = '/tmp';
    }

    # We use /dev/shm to store the file, so it needs to be writeable
    if ( !-w $storeLocksIn ) {
        die( $storeLocksIn
              . ": is not writeable. Unable to write lockfile. Use the --no-lock parameter to\ndisable use of a lockfile.\n"
        );
    }

# The path to the lockfile. User-specific filename since /dev/shm could be shared.
    my $locked =
      $storeLocksIn . '/.perl-cli-app-template-' . $< . '-' . $> . '.lock';
    my $alreadyRunning = 0;

    # If we have a lockfile
    if ( -e $locked ) {

        # Fetch the PID from it
        my $PID = slurp($locked);
        sayd("Lockfile existed, containing $PID");

        # If the PID looks like a real PID and is running
        if ( $PID =~ /^\d+$/ && $PID ne $$ && kill( 0, $PID ) ) {

            # On linux, we verify the cmdline, so that we're sure it's us, and
            # not a new process with the same PID
            if ( $^O eq 'linux' ) {
                if ( -r '/proc/' . $PID . '/cmdline' ) {

                    # Read the cmdline
                    my $cmdline = slurp( '/proc/' . $PID . '/cmdline' );

                    # Find out our own name
                    my $appname = basename($0);

# Check for our name in the cmdline of the process with the PID from the lockfile
# If all matches, then it looks like a copy of the helper is already running
                    if ( index( $cmdline, $appname ) != -1 ) {
                        $alreadyRunning = 1;
                    }
                }
            }

            # On anything else, the PID existing is as far as we'll go, so we
            # assume the lockfile is valid.
            else {
                $alreadyRunning = 1;
            }
        }
        if ($alreadyRunning) {
            if ( $verbosity > -1 ) {
                warn(   basename($0)
                      . " appears to already be running (PID $PID). Refusing to run a second instance.\n"
                      . "If you are sure it's not running, or want to force-start a second instance,\n"
                      . "either use the --no-lock parameter or remove the $locked file\n"
                );
            }
            exit(5);
        }
        sayd("Lockfile is no longer valid - ignoring it");
    }
    spurt( $locked, $$ );
    sayd("Wrote lockfile to $locked");
}

# Simple usage info
sub usage($exit) {
    say "Usage: $0 [options]";
    say "";
    say "Options:";
    say "  -h, --help                 Display this help screen and exit.";
    say "  -v, --verbose              Increase verbosity.";
    say "  -q, --quiet                Only output errors.";
    say
"      --no-lock              Bypass the lockfile, allowing multiple instances";
    say "                             to run at the same time.";
    say "      --debug                Output debugging information as well.";

    if ( defined $exit ) {
        exit $exit;
    }
}

# Wrapper around 'say' that appends the program name to it
sub sayw($message) {
    say 'perl-cli-app-template: ' . $message;
}

# Outputs a message unless we're in quiet mode
sub saym($message) {
    if ( $verbosity > -1 ) {
        sayw($message);
    }
}

# Outputs a message in verbose mode
sub sayv($message) {
    if ( $verbosity > 0 ) {
        sayw($message);
    }
}

# Outputs a debugging message
sub sayd($message) {
    if ( $verbosity >= 100 ) {
        sayw($message);
    }
}

sub main () {
    my $noLock = 0;
    Getopt::Long::Configure( 'no_ignore_case', 'bundling' );
    GetOptions(
        'verbose|v' => sub { $verbosity++; },
        'debug'     => sub { $verbosity = 100; },
        'quiet|q'   => sub { $verbosity = -1; },
        'no-lock'   => \$noLock,
        'help'      => sub { usage(0); },
    );
    if ( !$noLock ) {
        lockOrDie();
    }
}
main();