File Coverage

blib/lib/Role/RunAlone.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	20	20	100.0
condition			n/a
subroutine	13	13	100.0
pod	1	1	100.0
total	87	87	100.0

package Role::RunAlone;

use 5.006;
use strict;
use warnings;

our $VERSION = 'v0.0.0_03';

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

use Role::Tiny;

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

my $data_pkg   = 'main::DATA';
my $caller_cnt = 0;

# use a block because the pragmas have 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, and the
        # __DATA__ tag is not in the "main" namespace. swap in the
        # calling script namespace to see if the __DATA__ tag is in there.
        while ( ++$caller_cnt ) {
            my @call_info = caller($caller_cnt);
            last if !@call_info;
            $data_pkg = $call_info[0] . '::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{$_} unless defined( $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;
    while ( $args{attempts}-- > 0 ) {
        warn "Attempting to lock $data_pkg ...\n" if $args{verbose};
        last if $ret = $proto->_runalone_lock;
        warn "Failed, retrying $args{attempts} more time(s)\n"
          if $args{verbose};

        sleep( $args{interval} ) if $args{attempts};
    }

    if ($ret) {
        warn "SUCCESS\n" if $args{verbose};
    }
    elsif ( !$args{noexit} ) {
        warn "FATAL: A copy of '$0' is already running\n";
        __PACKAGE__->_runalone_exit(1);
    }

    return $ret;
}

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

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

# mock this out in tests
sub _runalone_exit {
    my $proto = shift;

    exit( shift );
}

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

    return { package => $1, caller => $caller_cnt };
}

1;
__END__