File Coverage

blib/lib/Test/Time/HiRes.pm

Criterion	Covered	Total	%
statement	66	69	95.6
branch	19	24	79.1
condition			n/a
subroutine	16	16	100.0
pod	0	2	0.0
total	101	111	90.9

package Test::Time::HiRes;

use strict;
use warnings;

use Test::More;
use Test::Time;
use Time::HiRes ();

our $VERSION = '0.05';

our $time    = 0;    # epoch in microseconds
our $seconds = 0;    # i.e. standard epoch

my $in_effect = 1;
my $imported  = 0;

sub in_effect {
    $in_effect;
}

sub set_time {
    my ( $class, $arg ) = @_;

    $Test::Time::time = $seconds = int($arg);    # epoch time in seconds
    $time = $arg * 1_000_000;                    # epoch time in microseconds
}

# synchronise times so time is correct whether using sleep() or usleep().
# - assume time only goes forwards
# - take the highest as current epoch time
sub _synchronise_times {

    if ( $seconds < $Test::Time::time ) {

        # update seconds from Test::Time, but keep the fractional microsecond part
        my $microseconds = _microseconds();    # part after DP
        $seconds = $Test::Time::time;
        $time    = ( $seconds * 1_000_000 ) + $microseconds;
    }
    elsif ( $seconds > $Test::Time::time ) {
        $Test::Time::time = $seconds;
    }
}

sub _microseconds {
    return 0 unless $time;
    return $time % 1_000_000;
}

sub _float {
    return 0 unless $time;
    my $t = $time / 1_000_000;
    return sprintf( "%.6f", $t ) + 0;
}

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

    $in_effect = 1;
    Test::Time->import;    # make sure Test::Time is enabled, in case
                           # there was a call to ->unimport earlier

    return if $imported;

    # If time set on import then use it and update
    # Test::Time, otherwise use $Test::Time::time
    if ( defined $opts{time} ) {
        $class->set_time( $opts{time} );
    }
    else {
        $seconds = $Test::Time::time;
        $time    = $seconds * 1_000_000;
    }

    no warnings 'redefine';

    # keep copies of the original subroutines
    my $sub_time         = \&Time::HiRes::time;
    my $sub_usleep       = \&Time::HiRes::usleep;
    my $sub_gettimeofday = \&Time::HiRes::gettimeofday;

    *Time::HiRes::time = sub() {
        if (in_effect) {
            _synchronise_times();

            return _float();
        }
        else {
            return $sub_time->();
        }
    };

    *Time::HiRes::usleep = sub($) {

        unless (@_) {
            return $sub_usleep->();    # always give "no argument" error
        }

        if (in_effect) {
            my $sleep = shift;

            _synchronise_times();

            return 0 unless $sleep;

            $time    = $time + $sleep;
            $seconds = int( $time / 1_000_000 );

            _synchronise_times();

            note "sleep $sleep";

            return $sleep;
        }
        else {
            return $sub_usleep->(shift);
        }
    };

    *Time::HiRes::gettimeofday = sub() {

        if (in_effect) {
            _synchronise_times();

            return wantarray ? ( $seconds, _microseconds() ) : _float();
        }
        else {
            return $sub_gettimeofday->();
        }
    };

    $imported++;
}

sub unimport {
    $in_effect = 0;
    Test::Time->unimport();
}

1;

__END__