File Coverage

blib/lib/Sub/Retry/Extended.pm

Criterion	Covered	Total	%
statement	56	58	96.5
branch	21	24	87.5
condition	17	19	89.4
subroutine	8	8	100.0
pod	1	1	100.0
total	103	110	93.6

package Sub::Retry::Extended;
use strict;
use warnings;
use Carp qw/croak/;
use Time::HiRes qw/sleep gettimeofday tv_interval/;
use parent qw/Exporter/;

our @EXPORT = qw/retryX/;

our $VERSION = '0.03';

sub retryX {
    my (%args) = @_;

    my $code = delete($args{code}) or croak 'require code';
    if (ref $code ne 'CODE') {
        croak "'code' is not code ref";
    }
    my $times    = delete($args{times}) || 1;
    my $delay    = delete($args{delay}) || delete($args{wait}) || 0;
    my $retry_if = delete($args{retry_if});
    if ($retry_if && ref $retry_if ne 'CODE') {
        croak "'retry_if' is not code ref";
    }
    my $timeout = {
        each  => delete($args{each_timeout})  || 0,
        total => delete($args{total_timeout}) || 0,
    };

    # Most of below codes have been copied from Sub::Retry
    my $err;
    $retry_if ||= sub { $err = $@ };
    my $n = 0;
    my $lap = { start => [gettimeofday] };
    while ( $times-- > 0 ) {
        $n++;
        $lap->{each} = [gettimeofday];
        if (wantarray) {
            my @ret = eval { $code->($n) };
            unless ($retry_if->(@ret)) {
                return @ret;
            }
            _timeout($timeout, $lap);
        }
        elsif (not defined wantarray) {
            eval { $code->($n) };
            unless ($retry_if->()) {
                return;
            }
            _timeout($timeout, $lap);
        }
        else {
            my $ret = eval { $code->($n) };
            unless ($retry_if->($ret)) {
                return $ret;
            }
            _timeout($timeout, $lap);
        }
        sleep $delay if $times; # Do not sleep in last time
        _timeout($timeout, $lap);
    }
    die $err if $err;
}

sub _timeout {
    my ($timeout, $lap) = @_;

    if ( $timeout->{each}
            && tv_interval($lap->{each}) > $timeout->{each} ) {
        die 'retry timeout: each time';
    }

    if ( $timeout->{total}
            && tv_interval($lap->{start}) > $timeout->{total} ) {
        die 'retry timeout: total time';
    }

    return;
}

1;

__END__