File Coverage

blib/lib/Try/ALRM.pm

Criterion	Covered	Total	%
statement	51	55	92.7
branch	9	12	75.0
condition	9	15	60.0
subroutine	13	14	92.8
pod	6	6	100.0
total	88	102	86.2

use strict;
use warnings;

package Try::ALRM;

our $VERSION = q{1.00};

use Exporter qw/import/;
our @EXPORT    = qw(try_once retry ALRM finally timeout tries);
our @EXPORT_OK = qw(try_once retry ALRM finally timeout tries);

our $TIMEOUT = 60;
our $TRIES   = 3;

# setter/getter for $Try::ALRM::TIMEOUT
sub timeout (;$) {
    my $timeout = shift;
    if ( defined $timeout ) {
        _assert_timeout($timeout);
        $TIMEOUT = $timeout;
    }
    return $TIMEOUT;
}

# setter/getter for $Try::ALRM::TRIES
sub tries (;$) {
    my $tries = shift;
    if ( defined $tries ) {
        _assert_tries($tries);
        $TRIES = $tries;
    }
    return $TRIES;
}

#NOTE: C a case of C, where C<< tries => 1 >>.
sub try_once (&;@) {
    &retry( @_, tries => 1 );    #&retry, bypasses prototype
}

sub retry(&;@) {
    unshift @_, q{retry};        # adding marker, will be key for this &
    my %TODO = @_;
    my $TODO = \%TODO;

    my $RETRY   = $TODO->{retry}   // sub { };       # defaults to no-op
    my $ALRM    = $TODO->{ALRM}    // $SIG{ALRM};    # local ALRM defaults to global $SIG{ALRM}
    my $timeout = $TODO->{timeout} // $TIMEOUT;
    my $tries   = $TODO->{tries}   // $TRIES;
    my $FINALLY = $TODO->{finally} // sub { };

    local $TIMEOUT = $timeout;                       # make available to timeout(;$)
    local $TRIES   = $tries;                         # make available to tries(;$)

    my ( $attempts, $succeeded );

  TIMED_ATTEMPTS:
    for my $attempt ( 1 .. $TRIES ) {
        $attempts = $attempt;
        my $retry = 0;

        # NOTE: handler always becomes a local wrapper
        local $SIG{ALRM} = sub {
            ++$retry;
            if ( ref($ALRM) =~ m/^CODE$|::/ ) {
                $ALRM->($attempt);
            }
        };

        # actual alarm code
        alarm($timeout);
        $RETRY->($attempt);
        alarm 0;
        unless ( $retry == 1 ) {
            ++$succeeded;
            last;
        }
    }

    # "finally" (defaults to no-op 'sub {}' if block is not defined)
    $FINALLY->( $attempts, $succeeded );
}

sub ALRM (&;@) {
    unshift @_, q{ALRM};
    return @_;
}

sub finally (&;@) {
    unshift @_, q{finally};    # create marker, will be key for &
    return @_;
}

# internal method, validation
sub _assert_timeout {
    my $timeout = shift;
    if ( int $timeout <= 0 ) {
        die qq{timeout must be an integer >= 1!\n};
    }
}

# internal method, validation
sub _assert_tries {
    my $timeout = shift;
    if ( int $timeout <= 0 ) {
        die qq{timeout must be an integer >= 1!\n};
    }
}

__PACKAGE__

__END__