File Coverage

blib/lib/Sys/RunAlone/Flexible.pm

Criterion	Covered	Total	%
statement	33	52	63.4
branch	7	30	23.3
condition	1	11	9.0
subroutine	9	9	100.0
pod	1	1	100.0
total	51	103	49.5

## no critic: ValuesAndExpressions::ProhibitCommaSeparatedStatements

package Sys::RunAlone::Flexible;

our $DATE = '2019-09-03'; # DATE
our $VERSION = '0.004'; # VERSION

# make sure we're strict and verbose as possible
use strict;
use warnings;

# make sure we know how to lock
use Fcntl ':flock';

# process local storage
my $silent;
my $retry;

# this holds the package namespace of the calling script
our $pkg;

# this holds the package namespace of where a tag was found. it will always be
# main::DATA for __END__, or the namespace of the calling script if __DATA__
our $data_pkg = 'main::DATA';

sub lock {
    no warnings;
    no strict 'refs';

    # the environment variables have to be checked here since import doesn't
    # execute when brought in via "require".
    # NOTE: the evironment variables will override options that were passed in
    # via "use" if present!
    $silent = $ENV{SILENT_SYS_RUNALONE} if exists $ENV{SILENT_SYS_RUNALONE};
    $retry  = $ENV{RETRY_SYS_RUNALONE} if exists $ENV{RETRY_SYS_RUNALONE};

    # skipping
    if ( my $skip= $ENV{SKIP_SYS_RUNALONE} ) {
        print STDERR "Skipping " . __PACKAGE__ . " check for '$0'\n"
          if !$silent and $skip > 1;

        return;
    }
    elsif ( tell(*main::DATA) == -1 ) {

        # if we reach this then the __END__ tag does not exist. swap in the
        # calling script namespace to see if the __DATA__ tag exists.
        $data_pkg = $pkg . '::DATA';
        if ( ( tell( *{$data_pkg} ) == -1 ) ) {
            print STDERR "Add __END__ or __DATA__ to end of script '$0'"
              . " to be able use the features of Sys::RunALone\n";
            exit 2;
        }
    }

    # are we alone? $data_pkg will be set to wherever an appropriate tag was.
    if ( !flock *{$data_pkg}, LOCK_EX | LOCK_NB ) {

        # need to retry
        if ($retry) {
            print STDERR "Retrying lock attempt ...\n" unless $silent;
            my ( $times, $sleep )= split ',', $retry;
            $sleep ||= 1;
            while ( $times-- ) {
                sleep $sleep;

                # we're alone!
                goto ALLOK if flock *{$data_pkg}, LOCK_EX | LOCK_NB;
            }
            print STDERR "Retrying lock failed ...\n" unless $silent;
        }

        # we're done
        print STDERR "A copy of '$0' is already running\n" if !$silent;
        exit 1;
    }

  ALLOK:
    return;
}

#-------------------------------------------------------------------------------
#
# Standard Perl functionality
#
#-------------------------------------------------------------------------------
# import
#
#  IN: 1 class (not used)
#      2 .. N options (default: none)

sub import {
    shift;

    # support obsolete form of silencing
    $silent= 1, return if @_ == 1 and $_[0] and $_[0] eq 'silent';

    # huh?
    die "Must specify even number of parameters" if ( @_ & 1 ) == 1;

    # obtain parameters
    my %args= @_;
    $silent= delete $args{silent};
    $retry=  delete $args{retry};

    # sanity check
    if ( my @huh= sort keys %args ) {
        die "Don't know what to do with: @huh";
    }

    return;
} #import

{
    # it is at this point we can get the correct package namespace of the
    # calling script
    my @call_info = caller(0);
    $pkg = $call_info[0];

    # to shut up the 'Too late to run INIT block' warning
    no warnings 'void';
    INIT {
        lock();
    }
}

# satisfy -require-
1;

# ABSTRACT: make sure only one invocation of a script is active at a time

__END__