File Coverage

File:blib/lib/Test/Mockingbird/TimeTravel.pm
Coverage:100.0%

linestmtbrancondsubtimecode
1package Test::Mockingbird::TimeTravel;
2
3
7
7
7
7
395
5
86
use strict;
4
7
7
7
7
10
3
171
use warnings;
5
6
7
7
7
7
15
4
122
use Carp       qw(croak);
7
7
7
7
7
1433
6866
208
use Time::Local qw(timegm);
8
7
7
7
7
17
6
3210
use Exporter   'import';
9
10our @EXPORT = qw(
11        now
12        freeze_time
13        travel_to
14        advance_time
15        rewind_time
16        restore_all
17        with_frozen_time
18);
19
20# Unit-to-seconds conversion table.  Singular and plural forms accepted;
21# matching is case-insensitive (normalised in _unit_to_seconds).
22my %SECONDS_PER_UNIT = (
23        second  => 1,
24        seconds => 1,
25        minute  => 60,
26        minutes => 60,
27        hour    => 3600,
28        hours   => 3600,
29        day     => 86400,
30        days    => 86400,
31);
32
33# Internal state -- three package variables so that with_frozen_time()
34# can save/restore them with 'local'.
35our $ACTIVE        = 0;      # 1 when frozen, 0 when using real time
36our $CURRENT_EPOCH = undef;  # simulated time when frozen
37our $BASE_EPOCH    = undef;  # epoch at the moment of freeze()
38
39=encoding utf-8
40
41 - 49
=head1 NAME

Test::Mockingbird::TimeTravel - Deterministic, controllable time for Perl tests

=head1 VERSION

Version 0.14

=cut
50
51our $VERSION = '0.14';
52
53 - 126
=head1 SYNOPSIS

    use Test::Mockingbird::TimeTravel qw(
        now freeze_time travel_to advance_time rewind_time
        restore_all with_frozen_time
    );

    freeze_time('2025-01-01T00:00:00Z');
    is now(), 1735689600, 'time is frozen';

    advance_time(2 => 'minutes');
    is now(), 1735689720, 'time advanced deterministically';

    with_frozen_time '2025-01-02T12:00:00Z' => sub {
        is now(), 1735819200, 'block sees overridden time';
    };

    is now(), 1735689720, 'outer time restored after block';

    restore_all();
    isnt now(), 1735689720, 'real time restored';

=head1 DESCRIPTION

C<Test::Mockingbird::TimeTravel> provides a lightweight, deterministic
time-control layer for Perl tests. It does B<not> monkey-patch
C<CORE::time()>. Instead it provides a dedicated C<now()> function and a
small set of declarative operations that manipulate an internal frozen clock.

=head1 LIMITATIONS

=over 4

=item C<now()> is not a drop-in for C<time()>

Production code must call C<now()> for time control to take effect. Code
that calls C<CORE::time()>, C<POSIX::time()>, or C<Time::HiRes::time()>
directly is not affected.

=item Fractional seconds not supported

All timestamps are integer epoch seconds. Sub-second resolution is not
available.

=item Thread safety

C<$ACTIVE>, C<$CURRENT_EPOCH>, and C<$BASE_EPOCH> are package globals.
Concurrent threads that manipulate time state will race.

=back

=head1 METHODS

=head2 now

Return the current time.

Returns C<$CURRENT_EPOCH> when frozen, C<CORE::time()> otherwise.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    none

=head4 Output (Returns::Set schema)

    returns: Int  -- epoch seconds

=head3 FORMAL SPECIFICATION

    now ≙ ($ACTIVE = 1 ⇒ returns $CURRENT_EPOCH) ∧ ($ACTIVE = 0 ⇒ returns CORE::time())

=cut
127
128sub now () {
129
101
100
101
5127
        return $ACTIVE ? $CURRENT_EPOCH : CORE::time();
130}
131
132 - 158
=head2 freeze_time

Freeze the clock at a specific timestamp.

    my $epoch = freeze_time('2025-01-01T00:00:00Z');

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    $timestamp -- Str|Int (see _parse_timestamp for accepted formats)

=head4 Output (Returns::Set schema)

    returns: Int  -- frozen epoch

=head3 MESSAGES

  "Invalid timestamp format for TimeTravel: ..." -- unrecognised format

=head3 FORMAL SPECIFICATION

    freeze_time ≙
      âˆ€ ts : Str|Int •
        post $ACTIVE' = 1 ∧ $CURRENT_EPOCH' = parse(ts) ∧ $BASE_EPOCH' = parse(ts)

=cut
159
160sub freeze_time {
161
60
60
39082
        my ($ts) = @_;
162
60
79
        $CURRENT_EPOCH = _parse_timestamp($ts);
163
59
873
        $BASE_EPOCH    = $CURRENT_EPOCH;
164
59
40
        $ACTIVE        = 1;
165
59
50
        return $CURRENT_EPOCH;
166}
167
168 - 196
=head2 travel_to

Move the frozen clock to a new timestamp without unfreezing.

    travel_to('2025-06-01T00:00:00Z');

Croaks if called while TimeTravel is inactive.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    $timestamp -- Str|Int

=head4 Output (Returns::Set schema)

    returns: Int  -- new epoch

=head3 MESSAGES

  "travel_to() called while TimeTravel is inactive" -- freeze_time() not called first

=head3 FORMAL SPECIFICATION

    travel_to ≙
      pre  $ACTIVE = 1
      post $CURRENT_EPOCH' = parse(ts) ∧ $BASE_EPOCH unchanged ∧ $ACTIVE unchanged

=cut
197
198sub travel_to {
199
8
100
8
1345
        croak 'travel_to() called while TimeTravel is inactive' unless $ACTIVE;
200
5
6
        $CURRENT_EPOCH = _parse_timestamp($_[0]);
201
5
64
        return $CURRENT_EPOCH;
202}
203
204 - 235
=head2 advance_time

Advance the frozen clock by a duration.

    advance_time(30);              # 30 seconds
    advance_time(2 => 'minutes');  # 2 minutes

Croaks if called while TimeTravel is inactive.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    $amount -- Int
    $unit   -- Str, optional (second|minute|hour|day, plural forms ok)

=head4 Output (Returns::Set schema)

    returns: Int  -- new epoch

=head3 MESSAGES

  "advance_time() called while TimeTravel is inactive" -- not frozen
  "Unknown time unit '...'"                            -- unrecognised unit string

=head3 FORMAL SPECIFICATION

    advance_time ≙
      pre  $ACTIVE = 1
      post $CURRENT_EPOCH' = $CURRENT_EPOCH + to_seconds(amount, unit)

=cut
236
237sub advance_time {
238
24
100
24
1389
        croak 'advance_time() called while TimeTravel is inactive' unless $ACTIVE;
239
21
22
        my ($amount, $unit) = @_;
240
21
23
        $CURRENT_EPOCH += _unit_to_seconds($amount, $unit);
241
19
16
        return $CURRENT_EPOCH;
242}
243
244 - 274
=head2 rewind_time

Rewind the frozen clock by a duration.

    rewind_time(30);           # 30 seconds
    rewind_time(1 => 'hour');  # 1 hour

Croaks if called while TimeTravel is inactive.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    $amount -- Int
    $unit   -- Str, optional

=head4 Output (Returns::Set schema)

    returns: Int  -- new epoch

=head3 MESSAGES

  "rewind_time() called while TimeTravel is inactive" -- not frozen

=head3 FORMAL SPECIFICATION

    rewind_time ≙
      pre  $ACTIVE = 1
      post $CURRENT_EPOCH' = $CURRENT_EPOCH - to_seconds(amount, unit)

=cut
275
276sub rewind_time {
277
16
100
16
1358
        croak 'rewind_time() called while TimeTravel is inactive' unless $ACTIVE;
278
12
12
        my ($amount, $unit) = @_;
279
12
16
        $CURRENT_EPOCH -= _unit_to_seconds($amount, $unit);
280
12
11
        return $CURRENT_EPOCH;
281}
282
283 - 306
=head2 restore_all

Return to real time and clear all frozen state.

    restore_all();

Idempotent. Called automatically by L<Test::Mockingbird::DeepMock>.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    none

=head4 Output (Returns::Set schema)

    returns: undef

=head3 FORMAL SPECIFICATION

    restore_all ≙
      post $ACTIVE' = 0 ∧ $CURRENT_EPOCH' = undef ∧ $BASE_EPOCH' = undef

=cut
307
308sub restore_all {
309
119
119
31375
        $ACTIVE        = 0;
310
119
74
        $CURRENT_EPOCH = undef;
311
119
69
        $BASE_EPOCH    = undef;
312
119
104
        return;
313}
314
315 - 350
=head2 with_frozen_time

Temporarily override time inside a code block, restoring previous state
afterward even if the block throws.

    with_frozen_time '2025-01-02T12:00:00Z' => sub {
        is now(), 1735819200, 'block sees overridden time';
    };

Fully nestable.

=head3 API SPECIFICATION

=head4 Input (Params::Validate::Strict schema)

    $timestamp -- Str|Int
    $code      -- CodeRef

=head4 Output (Returns::Set schema)

    returns: Any  -- whatever $code returns

=head3 MESSAGES

  "with_frozen_time() requires a coderef"    -- second arg not a CodeRef
  "with_frozen_time() requires a timestamp"  -- first arg undefined

=head3 FORMAL SPECIFICATION

    with_frozen_time ≙
      âˆ€ ts : Str|Int; code : CodeRef •
        pre  defined(ts) ∧ ref(code) = 'CODE'
        post (save prev_state; freeze(ts); run code; restore prev_state)
             âˆ§ exceptions rethrown

=cut
351
352sub with_frozen_time {
353
23
23
7780
        my ($ts, $code) = @_;
354
355
23
100
55
        croak 'with_frozen_time() requires a coderef'
356                unless ref($code) eq 'CODE';
357
358
20
100
35
        croak 'with_frozen_time() requires a timestamp'
359                unless defined $ts;
360
361        # Save state so nested calls restore correctly
362
16
17
        my ($prev_active, $prev_epoch, $prev_base) =
363                ($ACTIVE, $CURRENT_EPOCH, $BASE_EPOCH);
364
365
16
13
        $CURRENT_EPOCH = _parse_timestamp($ts);
366
16
216
        $BASE_EPOCH    = $CURRENT_EPOCH;
367
16
12
        $ACTIVE        = 1;
368
369
16
10
        my (@ret, $err);
370        {
371
16
16
12
7
                local $@;
372
16
16
14
18
                @ret = eval { $code->() };
373
16
1282
                $err = $@;
374        }
375
376
16
13
        $ACTIVE        = $prev_active;
377
16
9
        $CURRENT_EPOCH = $prev_epoch;
378
16
11
        $BASE_EPOCH    = $prev_base;
379
380        # Re-throw as croak to stay consistent with the rest of this module
381
16
100
30
        croak $err if $err;
382
383
12
100
24
        return wantarray ? @ret : $ret[0];
384}
385
386# _parse_timestamp -- Private
387#
388# Purpose:      Convert a timestamp string to an integer epoch value.
389#               Supports: raw epoch integer, ISO8601 UTC (YYYY-MM-DDTHH:MM:SSZ),
390#               space-separated (YYYY-MM-DD HH:MM:SS), date-only (YYYY-MM-DD).
391# Entry:        $_[0] -- Str, non-empty timestamp
392# Exit:         Int, epoch seconds
393# Side effects: none
394sub _parse_timestamp {
395
114
114
9753
        my $ts = $_[0];
396
397
114
100
100
229
        croak 'Invalid timestamp format for TimeTravel: (undef)'
398                unless defined $ts && length $ts;
399
400
111
264
        $ts =~ s/^\s+|\s+$//g;   # trim whitespace
401
402        # Raw epoch integer -- return unchanged
403
111
100
174
        return $ts if $ts =~ /^\d+$/;
404
405        # ISO8601 UTC: YYYY-MM-DDTHH:MM:SSZ
406
107
100
189
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})Z$/) {
407
100
156
                return timegm($6, $5, $4, $3, $2 - 1, $1);
408        }
409
410        # Space-separated: YYYY-MM-DD HH:MM:SS
411
7
100
13
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})\s+(\d{2}):(\d{2}):(\d{2})$/) {
412
2
5
                return timegm($6, $5, $4, $3, $2 - 1, $1);
413        }
414
415        # Date-only: YYYY-MM-DD interpreted as midnight UTC
416
5
100
11
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
417
2
5
                return timegm(0, 0, 0, $3, $2 - 1, $1);
418        }
419
420
3
14
        croak "Invalid timestamp format for TimeTravel: $ts";
421}
422
423# Backwards-compatible alias used in some older tests.
424
18
18
1672
sub _parse_datetime { _parse_timestamp(@_) }
425
426# _unit_to_seconds -- Private
427#
428# Purpose:      Convert (amount, unit) into a number of seconds.
429#               Unit is optional (raw seconds assumed if absent).
430# Entry:        $amount -- Int; $unit -- Str or undef
431# Exit:         Int, seconds
432# Side effects: none
433sub _unit_to_seconds {
434
44
44
5375
        my ($amount, $unit) = @_;
435
436
44
100
48
        return $amount unless defined $unit;
437
438
35
32
        my $key = lc $unit;
439        croak "Unknown time unit '$unit'"
440
35
100
46
                unless exists $SECONDS_PER_UNIT{$key};
441
442
32
37
        return $amount * $SECONDS_PER_UNIT{$key};
443}
444
445 - 473
=head1 SUPPORT

Please report bugs at L<https://github.com/nigelhorne/Test-Mockingbird/issues>.

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 SEE ALSO

=over 4

=item * L<Test::Mockingbird>

=item * L<Test::Mockingbird::DeepMock>

=back

=head1 REPOSITORY

L<https://github.com/nigelhorne/Test-Mockingbird>

=head1 LICENCE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to GPL2 licence terms.

=cut
474
4751;