File Coverage

blib/lib/Try/ALRM.pm

Criterion	Covered	Total	%
statement	113	118	95.7
branch	37	44	84.0
condition	24	31	77.4
subroutine	20	20	100.0
pod	6	6	100.0
total	200	219	91.3

use strict;
use warnings;

package Try::ALRM;

# ABSTRACT: Structured retry and timeout handling using CORE::alarm

our $VERSION = q{1.06};

use Exporter qw/import/;
use Scalar::Util qw/refaddr/;
use Time::HiRes qw/time/;

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;

my @ALARM_STACK;

sub timeout (;$) {
    my $timeout = shift;
    if ( defined $timeout ) {
        _assert_timeout($timeout);
        $TIMEOUT = $timeout;
    }
    return $TIMEOUT;
}

sub tries (;$) {
    my $tries = shift;
    if ( defined $tries ) {
        _assert_tries($tries);
        $TRIES = $tries;
    }
    return $TRIES;
}

sub try_once (&;@) {
    my $block = shift;
    &retry( $block, @_, tries => 1 );    # bypass prototype intentionally
}

sub retry (&;@) {
    my $block = shift;

    my $spec = _parse_retry_args(@_);

    my $retry_block   = $block;
    my $alarm_block   = $spec->{ALRM};
    my $finally_block = $spec->{finally} || sub { };

    my $timeout = exists $spec->{timeout} ? $spec->{timeout} : $TIMEOUT;
    my $tries   = exists $spec->{tries}   ? $spec->{tries}   : $TRIES;

    _assert_timeout($timeout);
    _assert_tries($tries);

    local $TIMEOUT = $timeout;
    local $TRIES   = $tries;

    my $attempts  = 0;
    my $succeeded = 0;
    my $error;

    ATTEMPT:
    for my $attempt ( 1 .. $tries ) {
        $attempts = $attempt;

        my $alarm_token = bless \( my $token = "Try::ALRM timeout" ),
            'Try::ALRM::_Timeout';

        local $SIG{ALRM} = \&_dispatch_alarm;

        my $frame = _push_alarm_frame(
            timeout => $timeout,
            attempt => $attempt,
            handler => $alarm_block,
            token   => $alarm_token,
        );

        my $ok = eval {
            $retry_block->($attempt);
            _pop_alarm_frame($frame);
            1;
        };

        my $eval_error = $@;

        _pop_alarm_frame($frame);

        if ($ok) {
            $succeeded = 1;
            last ATTEMPT;
        }

        if (
            ref($eval_error)
            && ref($eval_error) eq 'Try::ALRM::_Timeout'
            && refaddr($eval_error) == refaddr($alarm_token)
        ) {
            next ATTEMPT;
        }

        $error = $eval_error || 'Unknown error';
        last ATTEMPT;
    }

    my $finally_error;
    eval {
        $finally_block->( $attempts, $succeeded );
        1;
    } or do {
        $finally_error = $@ || 'Unknown error';
    };

    die $error         if defined $error;
    die $finally_error if defined $finally_error;

    return;
}

sub ALRM (&;@) {
    return ALRM => @_;
}

sub finally (&;@) {
    return finally => @_;
}

sub _push_alarm_frame {
    my %frame = @_;

    $frame{deadline} = time() + $frame{timeout};

    push @ALARM_STACK, \%frame;
    _reset_alarm();

    return \%frame;
}

sub _pop_alarm_frame {
    my $frame = shift;

    return unless $frame;

    @ALARM_STACK = grep {
        refaddr($_) != refaddr($frame)
    } @ALARM_STACK;

    _reset_alarm();

    return;
}

sub _dispatch_alarm {
    my $now = time();

    my @expired = sort {
        $a->{deadline} <=> $b->{deadline}
    } grep {
        $_->{deadline} <= $now
    } @ALARM_STACK;

    unless (@expired) {
        _reset_alarm();
        return;
    }

    my $frame = $expired[0];

    if ( ref( $frame->{handler} ) eq 'CODE' ) {
        $frame->{handler}->( $frame->{attempt} );
    }

    die $frame->{token};
}

sub _reset_alarm {
    CORE::alarm(0);

    return unless @ALARM_STACK;

    my ($next) = sort {
        $a->{deadline} <=> $b->{deadline}
    } @ALARM_STACK;

    my $remaining = $next->{deadline} - time();

    if ( $remaining <= 0 ) {
        CORE::alarm(1);
        return;
    }

    CORE::alarm( _ceil($remaining) );

    return;
}

sub _ceil {
    my $value = shift;

    return int($value) == $value ? int($value) : int($value) + 1;
}

sub _parse_retry_args {
    my @args = @_;

    die "Odd number of arguments to retry\n" if @args % 2;

    my %spec;

    while (@args) {
        my ( $key, $value ) = splice @args, 0, 2;

        die "Unknown retry argument '$key'\n"
            unless $key eq 'ALRM'
                || $key eq 'finally'
                || $key eq 'timeout'
                || $key eq 'tries';

        die "Duplicate retry argument '$key'\n"
            if exists $spec{$key};

        if ( $key eq 'ALRM' || $key eq 'finally' ) {
            die "$key must be a CODE reference\n"
                unless ref($value) eq 'CODE';
        }

        $spec{$key} = $value;
    }

    return \%spec;
}

sub _assert_timeout {
    my $timeout = shift;

    die qq{timeout must be an integer >= 1!\n}
        unless defined $timeout
            && $timeout =~ /\A[1-9][0-9]*\z/;
}

sub _assert_tries {
    my $tries = shift;

    die qq{tries must be an integer >= 1!\n}
        unless defined $tries
            && $tries =~ /\A[1-9][0-9]*\z/;
}

__PACKAGE__;

__END__