File Coverage

blib/lib/Try/Tiny/Retry.pm

Criterion	Covered	Total	%
statement	76	78	97.4
branch	32	34	94.1
condition	3	3	100.0
subroutine	17	17	100.0
pod	5	5	100.0
total	133	137	97.0

use 5.006;
use strict;
use warnings;

package Try::Tiny::Retry;
# ABSTRACT: Extends Try::Tiny to allow retries
our $VERSION = '0.004'; # VERSION

use parent 'Exporter';
our @EXPORT      = qw/retry retry_if on_retry try catch finally/;
our @EXPORT_OK   = ( @EXPORT, qw/delay delay_exp/ );
our %EXPORT_TAGS = ( all => [@EXPORT_OK] );

use Carp;
$Carp::Internal{ +__PACKAGE__ }++;

use Try::Tiny;

BEGIN {
    eval "use Sub::Name; 1" or *{subname} = sub { 1 }
}

our $_DEFAULT_DELAY = 1e5; # to override for testing

sub delay(&;@) {           ## no critic
    my ( $block, @rest ) = @_;
    return ( bless( \$block, 'Try::Tiny::Retry::Delay' ), @rest, );
}

sub on_retry(&;@) {        ## no critic
    my ( $block, @rest ) = @_;
    return ( bless( \$block, 'Try::Tiny::Retry::OnRetry' ), @rest, );
}

sub retry_if(&;@) {        ## no critic
    my ( $block, @rest ) = @_;
    return ( bless( \$block, 'Try::Tiny::Retry::RetryIf' ), @rest, );
}

sub delay_exp(&;@) {       ## no critic
    my ( $params, @rest )  = @_;
    my ( $n,      $scale ) = $params->();

    require Time::HiRes;

    return delay {
        return if $_[0] >= $n;
        Time::HiRes::usleep( int rand( $scale * ( 1 << ( $_[0] - 1 ) ) ) );
    }, @rest;
}

sub retry(&;@) {           ## no critic
    my ( $try, @code_refs ) = @_;

    # name the block if we have Sub::Name
    my $caller = caller;
    subname( "${caller}::retry {...} " => $try );

    # we need to save this here to ensure retry block is evaluated correctly
    my $wantarray = wantarray;

    # find labeled blocks in the argument list: retry_if and delay tag by blessing
    # a scalar reference to the code block reference
    my ( $delay, $on_retry, @conditions, @rest );

    foreach my $code_ref (@code_refs) {
        if ( ref($code_ref) eq 'Try::Tiny::Retry::RetryIf' ) {
            push @conditions, $$code_ref;
        }
        elsif ( ref($code_ref) eq 'Try::Tiny::Retry::OnRetry' ) {
            croak 'A retry() may not be followed by multiple on_retry blocks'
              if $on_retry;
            $on_retry = $$code_ref;
        }
        elsif ( ref($code_ref) eq 'Try::Tiny::Retry::Delay' ) {
            croak 'A retry() may not be followed by multiple delay blocks'
              if $delay;
            $delay = $$code_ref;
        }
        else {
            push @rest, $code_ref;
        }
    }

    # default retry 10 times with default exponential backoff
    if ( !defined $delay ) {
        my ($code_ref) = delay_exp { 10, $_DEFAULT_DELAY };
        $delay = $$code_ref;
    }

    # execute code block and retry as necessary
    my @ret;
    my $retry = sub {
        my $count = 0;
        RETRY: {
            $count++;
            my ( $redo, $err );
            try {
                # evaluate the try block in the correct context
                if ($wantarray) {
                    @ret = $try->();
                }
                elsif ( defined $wantarray ) {
                    $ret[0] = $try->();
                }
                else {
                    $try->();
                }
            }
            catch {
                $err = $_;
                # if there are conditions, rethrow unless at least one is met
                if (@conditions) {
                    my $met = 0;
                    for my $c (@conditions) {
                        local $_ = $err; # protect from modification
                        $met++ if $c->($count);
                    }
                    die $err unless $met;
                }
                # rethow if delay function signals stop with undef
                die $err unless defined $delay->($count);
                # if here, then we want to try again
                $redo++;
            };
            if ( defined $on_retry && $redo ) {
                local $_ = $err;
                $on_retry->($count);
            }

            redo RETRY if $redo;
        }
        return $wantarray ? @ret : $ret[0];
    };

    # call "&try" to bypass the prototype check
    return &try( $retry, @rest );
}

1;


# vim: ts=4 sts=4 sw=4 et:

__END__