File Coverage

blib/lib/Test/Timer.pm

Criterion	Covered	Total	%
statement	100	100	100.0
branch	20	20	100.0
condition	6	6	100.0
subroutine	21	21	100.0
pod	5	5	100.0
total	152	152	100.0

package Test::Timer;

use warnings;
use strict;

use vars qw($VERSION @ISA @EXPORT);
use Benchmark;    # timestr
use Carp qw(croak);
use Error qw(:try);
use Test::Builder;
use base 'Test::Builder::Module';

use constant TRUE  => 1;
use constant FALSE => 0;

#own
use Test::Timer::TimeoutException;

@EXPORT = qw(time_ok time_nok time_atleast time_atmost time_between);

$VERSION = '2.12';

my $test    = Test::Builder->new;
my $timeout = 0;

# TODO: this should be renamed to ALARM to adhere with Variables::ProhibitPackageVars
our $alarm = 2;    # default alarm

# syntactic sugar for time_atmost
sub time_ok {
    return time_atmost(@_);
}

# inverse test of time_ok
sub time_nok {
    my ( $code, $upperthreshold, $name ) = @_;

    # timing from zero to upper threshold
    my ( $within, $time ) = _runtest( $code, 0, $upperthreshold );

    # are we within the specified threshold
    if ( $within == TRUE ) {

        # we inverse the result, since we are the inverse of time_ok
        $within = FALSE;
        $test->ok( $within, $name );    # no, we fail
        $test->diag(
            "Test ran $time seconds and did not exceed specified threshold of $upperthreshold seconds"
        );
    }
    else {

        # we inverse the result, since we are the inverse of time_ok
        $within = TRUE;
        $test->ok( $within, $name );    # yes, we do not fail
    }

    return $within;
}

# test to make sure we are below a specified threshold
sub time_atmost {
    my ( $code, $upperthreshold, $name ) = @_;

    # timing from zero to upper threshold
    my ( $within, $time ) = _runtest( $code, 0, $upperthreshold );

    # are we within the specified threshold
    if ( $within == TRUE ) {
        $test->ok( $within, $name );    # yes, we do not fail
    }
    else {
        $test->ok( $within, $name );    # no, we fail
        $test->diag(
            "Test ran $time seconds and exceeded specified threshold of $upperthreshold seconds"
        );
    }

    return $within;
}

# test to make sure we are above a specified threshold
sub time_atleast {
    my ( $code, $lowerthreshold, $name ) = @_;

    # timing from lowerthreshold to nothing
    my ( $above, $time ) = _runtest( $code, $lowerthreshold, undef );

    # are we above the specified threshold
    if ( $above == TRUE ) {
        $test->ok( $above, $name );    # yes, we do not fail

    }
    else {
        $test->ok( $above, $name );    # no, we fail
        $test->diag(
            "Test ran $time seconds and did not exceed specified threshold of $lowerthreshold seconds"
        );
    }

    return $above;
}

# test to make sure we are witin a specified threshold time frame
sub time_between {
    my ( $code, $lowerthreshold, $upperthreshold, $name ) = @_;

    # timing from lower to upper threshold
    my ( $within, $time ) =
        _runtest( $code, $lowerthreshold, $upperthreshold );

    # are we within the specified threshold
    if ( $within == TRUE ) {
        $test->ok( $within, $name );    # yes, we do not fail
    }
    else {
        $test->ok( $within, $name );    # no, we fail
        if ($timeout) {
            $test->diag(
                "Execution ran $timeout seconds and did not execute within specified interval $lowerthreshold - $upperthreshold seconds and timed out"
            );
        }
        else {
            $test->diag(
                "Test ran $time seconds and did not execute within specified interval $lowerthreshold - $upperthreshold seconds"
            );
        }
    }

    return $within;
}

# helper routine to make initiate timing and make initial interpretation of results
# test mehtods do the final interpretation
sub _runtest {
    my ( $code, $lowerthreshold, $upperthreshold ) = @_;

    my $ok   = FALSE;
    my $time = 0;

    try {

 # we have both a lower and upper threshold (time_between, time_most, time_ok)
        if ( defined $lowerthreshold and defined $upperthreshold ) {

            $time = _benchmark( $code, $upperthreshold );

            if ( $time >= $lowerthreshold and $time <= $upperthreshold ) {
                $ok = TRUE;
            }
            else {
                $ok = FALSE;
            }

            # we just have a lower threshold (time_atleast)
        }
        elsif ( defined $lowerthreshold ) {

            $time = _benchmark($code);

            if ( $time >= $lowerthreshold ) {
                $ok = TRUE;
            }
            else {
                $ok = FALSE;
            }
        }
    }

    # catching a timeout so we do not run forever
    catch Test::Timer::TimeoutException with {
        my $E = shift;

        $timeout = $E->{-text};

        return ( undef, $time );    # we return undef as result
    };

    return ( $ok, $time );
}

# actual timing using benchmark
sub _benchmark {
    my ( $code, $threshold ) = @_;

    my $time = 0;

    # We default to no alarm
    my $local_alarm = 0;

    # We only define an alarm if we have an upper threshold
    # alarm is based on upper threshold + default alarm
    # default alarm can be extended, see the docs
    if ( defined $threshold ) {
        $local_alarm = $threshold + $alarm;
    }

    # setting first benchmark
    my $t0 = Benchmark->new();

    # defining alarm signal handler
    # the handler takes care of terminating the
    # benchmarking
    local $SIG{ALRM} = sub {

        my $t_alarm = Benchmark->new();

        my $alarm_time_string = timediff( $t_alarm, $t0 )->real;

        throw Test::Timer::TimeoutException($alarm_time_string);
    };

    # setting alarm
    alarm $local_alarm;

    # running code
    &{$code};

    # clear alarm
    alarm 0;

    # setting second benchmark
    my $t1 = Benchmark->new();

    # parsing benchmark output
    my $timestring = timediff( $t1, $t0 )->real;

    return $timestring;
}

1;

__END__