File Coverage

blib/lib/Test/Retry.pm

Criterion	Covered	Total	%
statement	70	73	95.8
branch	9	10	90.0
condition	5	9	55.5
subroutine	17	18	94.4
pod	1	1	100.0
total	102	111	91.8

package Test::Retry;
use strict;
use warnings;
use 5.008_001;
use Test::Builder;
use Time::HiRes qw(sleep);

our $VERSION = '0.01';

our $MAX_RETRIES = 5;
our $RETRY_DELAY = 0.5;

sub import {
    my ($class, %args) = @_;

    my $pkg = caller;
    my $retry_test = _mk_retry_test($args{max}, $args{delay});

    {
        no strict 'refs';
        *{"$pkg\::retry_test"} = $retry_test;
    }

    if (my @names = @{ $args{override} || [] }) {
        $class->_override_test_functions(
            package => $pkg,
            names => \@names,
            retry_test => $retry_test,
        );
    }
}

sub _retry_test_block {
    my ($max, $delay, $block) = @_;

    my $ORIGINAL_ok = \&Test::Builder::ok;

    my $retry;

    no warnings 'redefine';
    local *Test::Builder::ok = sub {
        my ($self, $test, $name) = @_;

        $retry = 0;
        $name = '' unless defined $name;

        if ($test) {
            goto \&$ORIGINAL_ok; # passes
        } elsif (--$max <= 0) {
            $self->diag("test '$name' failing; give up");
            goto \&$ORIGINAL_ok; # fails
        } else {
            $self->diag("test '$name' failing; retry ($max remaining)");
            $retry++;
        }
    };

    &$block;

    while ($retry) {
        sleep $delay;
        &$block;
    }
}

sub _mk_retry_test {
    my ($max, $delay) = @_;

    return sub (&) {
        my $block = shift;

        _retry_test_block(
            $max || $MAX_RETRIES,
            $delay || $RETRY_DELAY,
            $block,
        );
    };
}

sub override {
    my ($class, @names) = @_;
    my $pkg = caller;

    $class->_override_test_functions(
        package => $pkg,
        names => \@names,
    );
}

sub _override_test_functions {
    my ($class, %args) = @_;

    my $pkg = $args{package};
    my @names = @{ $args{names} };
    my $retry_test = $args{retry_test} || $pkg->can('retry_test') || _mk_retry_test();

    foreach my $name (@names) {
        my $original_code = $pkg->can($name);
        my $code = sub (&) {
            my $block = shift;
            $retry_test->(sub {
                my @args = $block->();
                $original_code->(@args);
            });
        };

        no strict 'refs';
        no warnings 'redefine', 'prototype';
        *{"$pkg\::$name"} = $code;
    }
}

1;

__END__