File Coverage

blib/lib/MooX/Role/RunAlone.pm

Criterion	Covered	Total	%
statement	51	56	91.0
branch	17	18	94.4
condition	5	8	62.5
subroutine	11	13	84.6
pod	1	1	100.0
total	85	96	88.5

package MooX::Role::RunAlone;

use 5.006;
use strict;
use warnings;

use Fcntl qw( :flock );
use Carp qw( croak );

#use Moo::Role;
use Role::Tiny;

our $VERSION = 'v0.0.0_03';

my %default_lock_args = (
    noexit   => 0,
    attempts => 1,
    interval => 1,
    verbose  => 0,
);

my $data_pkg = 'main::DATA';

my @call_info = caller(6);
my $pkg       = $call_info[0];

# use a block because the pragmas are lexical scope and we need
# to stop warnings/errors from the call to "tell()"
{
    no strict 'refs';
    no warnings;

    if ( tell( *{$data_pkg} ) == -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 ) ) {
            warn "FATAL: No __DATA__ or __END__ tag found\n";
            __PACKAGE__->_runalone_exit(2);
        }
    }
}

# maybe the script wants to control this
__PACKAGE__->runalone_lock unless !!$ENV{RUNALONE_DEFER_LOCK};

# is the argument validation over-engineered? maybe, but I'm paranoid.
sub runalone_lock {
    my $proto = shift;
    my %args  = @_;

    # set defaults as needed
    for ( keys(%default_lock_args) ) {
        $args{$_} //= $default_lock_args{$_};
    }

    croak 'ERROR: unknown argument present'
      if scalar( keys(%args) ) != scalar( keys(%default_lock_args) );

    # validate integer args
    for (qw( attempts interval )) {
        croak "$_: invalid value" unless $args{$_} =~ /^[1-9]$/;
    }

    # coerce Boolean args
    for (qw( noexit verbose )) {
        $args{$_} = !!$args{$_};
    }

    my $ret = 1;
    while ( $args{attempts}-- > 0 ) {
        warn "Attempting to lock $data_pkg ...\n" if $args{verbose};
        last if $proto->_runalone_lock( $args{noexit} );
        warn "Failed, retrying $args{attempts} more time(s)\n"
          if $args{verbose};
        if ( $args{attempts} ) {
            sleep $args{interval} if $args{attempts};
        }
        elsif ( $args{noexit} ) {
            $ret = 0;
        }
        else {
            warn "FATAL: A copy of '$0' is already running\n";
            __PACKAGE__->_runalone_exit(1);
        }
    }
    warn "SUCCESS\n" if $args{verbose} && $ret;

    return $ret;
}

# no need to mock Perl internal exit for tests
sub _runalone_exit {
    my $proto  = shift;
    my $status = shift // 0;

    exit($status);
}

# broken out for easier retry testing
sub _runalone_lock {
    my $proto  = shift;
    my $noexit = shift;

    no strict 'refs';
    return flock( *{$data_pkg}, LOCK_EX | LOCK_NB );
}

# helper for test scripts
sub _runalone_tag_pkg {
    $data_pkg =~ /^(.+)::DATA$/;

    return $1;
}

1;
__END__