File Coverage

blib/lib/Test/Timer.pm

Criterion	Covered	Total	%
statement	100	100	100.0
branch	19	20	95.0
condition	4	6	66.6
subroutine	21	21	100.0
pod	5	5	100.0
total	149	152	98.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.11';

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

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__