File Coverage

blib/lib/Test/Mock/Time.pm

Criterion	Covered	Total	%
statement	314	365	86.0
branch	93	162	57.4
condition	24	47	51.0
subroutine	62	70	88.5
pod	1	1	100.0
total	494	645	76.5

package Test::Mock::Time;
use 5.010001;
use warnings;
use strict;
use utf8;
use Carp;

our $VERSION = 'v0.1.6';

use Export::Attrs;
use List::Util qw( any );
use Scalar::Util qw( weaken );
use Test::MockModule;

use constant TIME_HIRES_CLOCK_NOT_SUPPORTED => -1;
use constant MICROSECONDS                   => 1_000_000;
use constant NANOSECONDS                    => 1_000_000_000;

use constant DEFAULT_WAIT_ONE_TICK => 0.05;
our $WAIT_ONE_TICK = DEFAULT_WAIT_ONE_TICK;

my $Absolute    = time; # usual time starts at current actual time
my $Monotonic   = 0;    # monotonic time starts at 0 if not available
my $Relative    = 0;    # how many deterministic time passed since start
my @Timers;             # active timers
my @Timers_ns;          # inactive timers
my %Module;             # keep module mocks


_mock_core_global();
## no critic (RequireCheckingReturnValueOfEval)
eval {
    require Time::HiRes;
    Time::HiRes->import(qw( CLOCK_REALTIME CLOCK_MONOTONIC ));
    _mock_time_hires();
};
eval {
    require EV;
    _mock_ev();
};
eval {
    require Mojolicious;
    Mojolicious->VERSION('6'); # may be compatible with older ones, needs testing
    require Mojo::Reactor::Poll;
    _mock_mojolicious();
};


# FIXME make ff() reentrant
sub ff :Export(:DEFAULT) {
    my ($dur) = @_;

    @Timers = sort {
        $a->{start}+$a->{after} <=> $b->{start}+$b->{after} or
        $a->{id} cmp $b->{id}   # preserve order to simplify tests
        } @Timers;
    my $next_at = @Timers ? $Timers[0]{start}+$Timers[0]{after} : 0;
    $next_at = sprintf '%.6f', $next_at;

    if (!defined $dur) {
        $dur = $next_at > $Relative ? $next_at - $Relative : 0;
        $dur = sprintf '%.6f', $dur;
    }
    croak "ff($dur): negative time not invented yet" if $dur < 0;

    if ($next_at == 0 || $next_at > $Relative+$dur) {
        $Relative += $dur;
        $Relative = sprintf '%.6f', $Relative;
        return;
    }

    if ($next_at > $Relative) {
        $dur -= $next_at - $Relative;
        $dur = sprintf '%.6f', $dur;
        $Relative = $next_at;
    }
    my $cb = $Timers[0]{cb};
    if ($Timers[0]{repeat} == 0) {
        if ($Timers[0]{watcher}) {
            _stop_timer($Timers[0]{watcher});
        }
        else {
            shift @Timers;
        }
    }
    else {
        $Timers[0]{after} = $Timers[0]{repeat};
        $Timers[0]{start} = $Relative;
    }
    $cb->();
    @_ = ($dur);
    goto &ff;
}

sub _add_timer {
    my ($loop, $after, $repeat, $cb, $watcher) = @_;
    state $next_id = 0;
    my $id = sprintf 'fake_%05d', $next_id++;
    push @Timers, {
        id      => $id,
        start   => $Relative,
        loop    => $loop,
        after   => sprintf('%.6f', $after < 0 ? 0 : $after),
        repeat  => sprintf('%.6f', $repeat < 0 ? 0 : $repeat),
        cb      => $cb,
        watcher => $watcher,
    };
    if ($watcher) {
        weaken($Timers[-1]{watcher});
    }
    return $id;
}

sub _start_timer {
    my ($watcher) = @_;
    my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $watcher } @Timers_ns;
    if ($timer) {
        @Timers_ns = grep { !$_->{watcher} || $_->{watcher} ne $watcher } @Timers_ns;
        push @Timers, $timer;
    }
    return;
}

sub _stop_timer {
    my ($watcher) = @_;
    my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $watcher } @Timers;
    if ($timer) {
        @Timers = grep { !$_->{watcher} || $_->{watcher} ne $watcher } @Timers;
        push @Timers_ns, $timer;
    }
    return;
}

sub _mock_core_global {
    $Module{'CORE::GLOBAL'} = Test::MockModule->new('CORE::GLOBAL', no_auto=>1);
    $Module{'CORE::GLOBAL'}->mock(time => sub () {
        return int($Absolute + $Relative);
    });
    $Module{'CORE::GLOBAL'}->mock(localtime => sub (;$) {
        my $time = $_[0] // int($Absolute + $Relative);
        return CORE::localtime($time);
    });
    $Module{'CORE::GLOBAL'}->mock(gmtime => sub (;$) {
        my $time = $_[0] // int($Absolute + $Relative);
        return CORE::gmtime($time);
    });
    $Module{'CORE::GLOBAL'}->mock(sleep => sub ($) {
        my $dur = int $_[0];
        croak 'sleep with negative value is not supported' if $dur < 0;
        $Relative += $dur;
        $Relative = sprintf '%.6f', $Relative;
        return $dur;
    });
    return;
}

sub _mock_time_hires {
    # Do not improve precision of current actual time to simplify tests.
    #$Absolute = Time::HiRes::time();
    # Use current actual monotonic time.
    $Monotonic = Time::HiRes::clock_gettime(CLOCK_MONOTONIC());

    $Module{'Time::HiRes'} = Test::MockModule->new('Time::HiRes');
    $Module{'Time::HiRes'}->mock(time => sub () {
        return 0+sprintf '%.6f', $Absolute + $Relative;
    });
    $Module{'Time::HiRes'}->mock(gettimeofday => sub () {
        my $t = sprintf '%.6f', $Absolute + $Relative;
        return wantarray ? (map {0+$_} split qr/[.]/ms, $t) : 0+$t;
    });
    $Module{'Time::HiRes'}->mock(clock_gettime => sub (;$) {
        my ($which) = @_;
        if ($which == CLOCK_REALTIME()) {
            return 0+sprintf '%.6f', $Absolute + $Relative;
        }
        elsif ($which == CLOCK_MONOTONIC()) {
            return 0+sprintf '%.6f', $Monotonic + $Relative;
        }
        return TIME_HIRES_CLOCK_NOT_SUPPORTED;
    });
    $Module{'Time::HiRes'}->mock(clock_getres => sub (;$) {
        my ($which) = @_;
        if ($which == CLOCK_REALTIME() || $which == CLOCK_MONOTONIC()) {
            return $Module{'Time::HiRes'}->original('clock_getres')->(@_);
        }
        return TIME_HIRES_CLOCK_NOT_SUPPORTED;
    });
    $Module{'Time::HiRes'}->mock(sleep => sub (;@) {
        my ($seconds) = @_;
        croak 'sleep without arg is not supported' if !@_;
        croak "Time::HiRes::sleep($seconds): negative time not invented yet" if $seconds < 0;
        $Relative += $seconds;
        $Relative = sprintf '%.6f', $Relative;
        return $seconds;
    });
    $Module{'Time::HiRes'}->mock(usleep => sub ($) {
        my ($useconds) = @_;
        croak "Time::HiRes::usleep($useconds): negative time not invented yet" if $useconds < 0;
        $Relative += $useconds / MICROSECONDS;
        $Relative = sprintf '%.6f', $Relative;
        return $useconds;
    });
    $Module{'Time::HiRes'}->mock(nanosleep => sub ($) {
        my ($nanoseconds) = @_;
        croak "Time::HiRes::nanosleep($nanoseconds): negative time not invented yet" if $nanoseconds < 0;
        $Relative += $nanoseconds / NANOSECONDS;
        $Relative = sprintf '%.6f', $Relative;
        return $nanoseconds;
    });
    $Module{'Time::HiRes'}->mock(clock_nanosleep => sub ($$;$) {
        my ($which, $nanoseconds, $flags) = @_;
        croak "Time::HiRes::clock_nanosleep(..., $nanoseconds): negative time not invented yet" if $nanoseconds < 0;
        croak 'only CLOCK_REALTIME and CLOCK_MONOTONIC are supported' if $which != CLOCK_REALTIME() && $which != CLOCK_MONOTONIC();
        croak 'only flags=0 is supported' if $flags;
        $Relative += $nanoseconds / NANOSECONDS;
        $Relative = sprintf '%.6f', $Relative;
        return $nanoseconds;
    });
    return;
}

# TODO Distinguish timers set on different event loops / Mojo reactor
# objects while one_tick?

sub _mock_ev { ## no critic (ProhibitExcessComplexity)
    $Module{'EV'}           = Test::MockModule->new('EV');
    $Module{'EV::Watcher'}  = Test::MockModule->new('EV::Watcher',  no_auto=>1);
    $Module{'EV::Timer'}    = Test::MockModule->new('EV::Timer',    no_auto=>1);
    $Module{'EV::Periodic'} = Test::MockModule->new('EV::Periodic', no_auto=>1);
    $Module{'EV'}->mock(time => sub () {
        return 0+sprintf '%.6f', $Absolute + $Relative;
    });
    $Module{'EV'}->mock(now => sub () {
        return 0+sprintf '%.6f', $Absolute + $Relative;
    });
    $Module{'EV'}->mock(sleep => sub ($) {
        my ($seconds) = @_;
        if ($seconds < 0) {
            $seconds = 0;
        }
        $Relative += $seconds;
        $Relative = sprintf '%.6f', $Relative;
        return;
    });
    $Module{'EV'}->mock(run => sub (;$) {
        my ($flags) = @_;
        my $tick = 0;
        my $w;
        if (@Timers) {
            $w = $Module{'EV'}->original('timer')->(
                $WAIT_ONE_TICK, $WAIT_ONE_TICK, sub {
                    my $me = shift;
                    my $k;
                    if (!$tick++ || !$flags) {
                        $k = $me->keepalive(0);
                        ff();
                    }
                    if (!@Timers) {
                        $me->stop;
                    }
                    elsif ($k && ($flags || any {$_->{watcher} && $_->{watcher}->keepalive} @Timers)) {
                        $me->keepalive(1);
                    }
                }
            );
            if (!($flags || any {$_->{watcher} && $_->{watcher}->keepalive} @Timers)) {
                $w->keepalive(0);
            }
        }
        # $tick above and this second RUN_ONCE is work around bug in EV-4.10+
        # http://lists.schmorp.de/pipermail/libev/2016q1/002656.html
        # FIXME I believe this workaround isn't correct with EV-4.03 - calling
        # RUN_ONCE twice must have side effect in processing two events
        # (at least one of them must be a non-timer event) instead of one.
        # To make it correct we probably need to mock all watcher types
        # to intercept invoking their callbacks and thus make it possible
        # to find out is first RUN_ONCE has actually called any callbacks.
        if ($flags && $flags == EV::RUN_ONCE()) {
            $Module{'EV'}->original('run')->(@_);
        }
        return $Module{'EV'}->original('run')->(@_);
    });
    $Module{'EV'}->mock(timer => sub ($$$) {
        my ($after, $repeat, $cb) = @_;
        my $w = $Module{'EV'}->original('timer_ns')->(@_);
        weaken(my $weakw = $w);
        _add_timer('EV', $after, $repeat, sub { $weakw && $weakw->invoke(EV::TIMER()) }, $w);
        return $w;
    });
    $Module{'EV'}->mock(timer_ns => sub ($$$) {
        my $w = EV::timer(@_);
        _stop_timer($w);
        return $w;
    });
    $Module{'EV'}->mock(periodic => sub ($$$$) {
        my ($at, $repeat, $reschedule_cb, $cb) = @_;
        croak 'reschedule_cb is not supported yet' if $reschedule_cb;
        $at = sprintf '%.6f', $at < 0 ? 0 : $at;
        $repeat = sprintf '%.6f', $repeat < 0 ? 0 : $repeat;
        my $now = sprintf '%.6f', $Absolute + $Relative;
        if ($repeat > 0 && $at < $now) {
            use bignum;
            $at += $repeat * int(($now - $at) / $repeat + 1);
            $at = sprintf '%.6f', $at;
        }
        my $after = $at > $now ? $at - $now : 0;
        $after = sprintf '%.6f', $after;
        my $w = $Module{'EV'}->original('periodic_ns')->(@_);
        weaken(my $weakw = $w);
        _add_timer('EV', $after, $repeat, sub { $weakw && $weakw->invoke(EV::TIMER()) }, $w);
        return $w;
    });
    $Module{'EV'}->mock(periodic_ns => sub ($$$$) {
        my $w = EV::periodic(@_);
        _stop_timer($w);
        return $w;
    });
    $Module{'EV::Watcher'}->mock(is_active => sub {
        my ($w) = @_;
        my ($active) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers;
        my ($inactive) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers_ns;
        if ($active) {
            return 1;
        }
        elsif ($inactive) {
            return;
        }
        return $Module{'EV::Watcher'}->original('is_active')->(@_);
    });
    $Module{'EV::Timer'}->mock(DESTROY => sub {
        my ($w) = @_;
        @Timers = grep { !$_->{watcher} || $_->{watcher} ne $w } @Timers;
        @Timers_ns = grep { !$_->{watcher} || $_->{watcher} ne $w } @Timers_ns;
        return $Module{'EV::Timer'}->original('DESTROY')->(@_);
    });
    $Module{'EV::Timer'}->mock(start => sub {
        return _start_timer(@_);
    });
    $Module{'EV::Timer'}->mock(stop => sub {
        return _stop_timer(@_);
    });
    $Module{'EV::Timer'}->mock(set => sub {
        my ($w, $after, $repeat) = @_;
        $repeat //= 0;
        my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers, @Timers_ns;
        if ($timer) {
            $timer->{start} = $Relative;
            $timer->{after} = sprintf '%.6f', $after < 0 ? 0 : $after;
            $timer->{repeat}= sprintf '%.6f', $repeat < 0 ? 0 : $repeat;
        }
        return;
    });
    $Module{'EV::Timer'}->mock(remaining => sub {
        my ($w) = @_;
        my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers, @Timers_ns;
        if ($timer) {
            return 0+sprintf '%.6f', $timer->{start} + $timer->{after} - $Relative;
        }
        return;
    });
    $Module{'EV::Timer'}->mock(again => sub {
        my ($w, $repeat) = @_;
        if (defined $repeat && $repeat < 0) {
            $repeat = 0;
        }
        my ($active) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers;
        my ($inactive) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers_ns;
        if ($active) {
            $active->{repeat} = sprintf '%.6f', $repeat // $active->{repeat};
            if ($active->{repeat} > 0) {
                $active->{after} = $active->{repeat};
                $active->{start} = $Relative;
            }
            else {
                _stop_timer($active->{watcher});
            }
        }
        elsif ($inactive) {
            $inactive->{repeat} = sprintf '%.6f', $repeat // $inactive->{repeat};
            if ($inactive->{repeat} > 0) {
                $inactive->{after} = $inactive->{repeat};
                $inactive->{start} = $Relative;
                _start_timer($inactive->{watcher});
            }
        }
        return;
    });
    $Module{'EV::Periodic'}->mock(DESTROY => sub {
        my ($w) = @_;
        @Timers = grep { !$_->{watcher} || $_->{watcher} ne $w } @Timers;
        @Timers_ns = grep { !$_->{watcher} || $_->{watcher} ne $w } @Timers_ns;
        return $Module{'EV::Periodic'}->original('DESTROY')->(@_);
    });
    $Module{'EV::Periodic'}->mock(start => sub {
        return _start_timer(@_);
    });
    $Module{'EV::Periodic'}->mock(stop => sub {
        return _stop_timer(@_);
    });
    $Module{'EV::Periodic'}->mock(set => sub {
        my ($w, $at, $repeat, $reschedule_cb, $cb) = @_;
        croak 'reschedule_cb is not supported yet' if $reschedule_cb;
        $at = sprintf '%.6f', $at < 0 ? 0 : $at;
        $repeat = sprintf '%.6f', $repeat < 0 ? 0 : $repeat;
        my $now = sprintf '%.6f', $Absolute + $Relative;
        if ($repeat > 0 && $at < $now) {
            use bignum;
            $at += $repeat * int(($now - $at) / $repeat + 1);
            $at = sprintf '%.6f', $at;
        }
        my $after = $at > $now ? $at - $now : 0;
        $after = sprintf '%.6f', $after;
        my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers, @Timers_ns;
        if ($timer) {
            $timer->{start} = $Relative;
            $timer->{after} = $after;
            $timer->{repeat}= $repeat;
        }
        return;
    });
    $Module{'EV::Periodic'}->mock(again => sub {
        return _start_timer(@_);
    });
    $Module{'EV::Periodic'}->mock(at => sub {
        my ($w) = @_;
        my ($timer) = grep { $_->{watcher} && $_->{watcher} eq $w } @Timers, @Timers_ns;
        if ($timer) {
            return 0+sprintf '%.6f', $timer->{start} + $timer->{after};
        }
        return;
    });
    return;
}

sub _mock_mojolicious {
    $Module{'Mojo::Reactor::Poll'} = Test::MockModule->new('Mojo::Reactor::Poll');
    $Module{'Mojo::Reactor::Poll'}->mock(one_tick => sub {
        my ($self) = @_;
        if (!@Timers) {
            return $Module{'Mojo::Reactor::Poll'}->original('one_tick')->(@_);
        }
        my $id = $Module{'Mojo::Reactor::Poll'}->original('timer')->(
            $self, $WAIT_ONE_TICK, sub { ff() }
        );
        $Module{'Mojo::Reactor::Poll'}->original('one_tick')->(@_);
        $Module{'Mojo::Reactor::Poll'}->original('remove')->($self, $id);
        return;
    });
    $Module{'Mojo::Reactor::Poll'}->mock(timer => sub {
        my ($self, $delay, $cb) = @_;
        if ($delay == 0) {  # do not fake timer for 0 seconds to avoid hang
            return $Module{'Mojo::Reactor::Poll'}->original('timer')->(@_);
        }
        return _add_timer($self, $delay, 0, sub { $cb->($self) });
    });
    $Module{'Mojo::Reactor::Poll'}->mock(recurring => sub {
        my ($self, $delay, $cb) = @_;
        return _add_timer($self, $delay, $delay, sub { $cb->($self) });
    });
    $Module{'Mojo::Reactor::Poll'}->mock(again => sub {
        my ($self, $id) = @_;
        if ($id !~ /\Afake_\d+\z/ms) {
            $Module{'Mojo::Reactor::Poll'}->original('again')->(@_);
        }
        else {
            my ($timer) = grep { $_->{id} eq $id } @Timers;
            if ($timer) {
                $timer->{start} = $Relative;
            }
        }
        return;
    });
    $Module{'Mojo::Reactor::Poll'}->mock(remove => sub {
        my ($self, $id) = @_;
        if ($id !~ /\Afake_\d+\z/ms) {
            $Module{'Mojo::Reactor::Poll'}->original('remove')->(@_);
        }
        else {
            @Timers = grep { $_->{loop} ne $self || $_->{id} ne $id } @Timers;
        }
        return;
    });
    $Module{'Mojo::Reactor::Poll'}->mock(reset => sub {
        my ($self) = @_;
        @Timers = grep { $_->{loop} ne $self } @Timers;
        return $Module{'Mojo::Reactor::Poll'}->original('reset')->(@_);
    });
    return;
}


1;
__END__