File Coverage

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

linestmtbrancondsubtimecode
1package Test::Mockingbird::TimeTravel;
2
3
7
7
7
7
397
5
65
use strict;
4
7
7
7
7
8
5
121
use warnings;
5
6
7
7
7
7
14
2
112
use Carp       qw(croak);
7
7
7
7
7
1406
6809
213
use Time::Local qw(timegm);
8
7
7
7
7
13
5
3292
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 - 47
=head1 NAME

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

=head1 VERSION

Version 0.13

=cut
48
49our $VERSION = '0.13';
50
51 - 124
=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
125
126sub now () {
127
101
100
101
4681
        return $ACTIVE ? $CURRENT_EPOCH : CORE::time();
128}
129
130 - 156
=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
157
158sub freeze_time {
159
60
60
35451
        my ($ts) = @_;
160
60
81
        $CURRENT_EPOCH = _parse_timestamp($ts);
161
59
923
        $BASE_EPOCH    = $CURRENT_EPOCH;
162
59
34
        $ACTIVE        = 1;
163
59
49
        return $CURRENT_EPOCH;
164}
165
166 - 194
=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
195
196sub travel_to {
197
8
100
8
1259
        croak 'travel_to() called while TimeTravel is inactive' unless $ACTIVE;
198
5
8
        $CURRENT_EPOCH = _parse_timestamp($_[0]);
199
5
62
        return $CURRENT_EPOCH;
200}
201
202 - 233
=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
234
235sub advance_time {
236
24
100
24
1254
        croak 'advance_time() called while TimeTravel is inactive' unless $ACTIVE;
237
21
26
        my ($amount, $unit) = @_;
238
21
22
        $CURRENT_EPOCH += _unit_to_seconds($amount, $unit);
239
19
16
        return $CURRENT_EPOCH;
240}
241
242 - 272
=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
273
274sub rewind_time {
275
16
100
16
1217
        croak 'rewind_time() called while TimeTravel is inactive' unless $ACTIVE;
276
12
13
        my ($amount, $unit) = @_;
277
12
16
        $CURRENT_EPOCH -= _unit_to_seconds($amount, $unit);
278
12
12
        return $CURRENT_EPOCH;
279}
280
281 - 304
=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
305
306sub restore_all {
307
119
119
29331
        $ACTIVE        = 0;
308
119
82
        $CURRENT_EPOCH = undef;
309
119
67
        $BASE_EPOCH    = undef;
310
119
99
        return;
311}
312
313 - 348
=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
349
350sub with_frozen_time {
351
23
23
7121
        my ($ts, $code) = @_;
352
353
23
100
54
        croak 'with_frozen_time() requires a coderef'
354                unless ref($code) eq 'CODE';
355
356
20
100
30
        croak 'with_frozen_time() requires a timestamp'
357                unless defined $ts;
358
359        # Save state so nested calls restore correctly
360
16
17
        my ($prev_active, $prev_epoch, $prev_base) =
361                ($ACTIVE, $CURRENT_EPOCH, $BASE_EPOCH);
362
363
16
16
        $CURRENT_EPOCH = _parse_timestamp($ts);
364
16
216
        $BASE_EPOCH    = $CURRENT_EPOCH;
365
16
12
        $ACTIVE        = 1;
366
367
16
9
        my (@ret, $err);
368        {
369
16
16
10
12
                local $@;
370
16
16
13
17
                @ret = eval { $code->() };
371
16
1062
                $err = $@;
372        }
373
374
16
13
        $ACTIVE        = $prev_active;
375
16
10
        $CURRENT_EPOCH = $prev_epoch;
376
16
9
        $BASE_EPOCH    = $prev_base;
377
378        # Re-throw as croak to stay consistent with the rest of this module
379
16
100
36
        croak $err if $err;
380
381
12
100
23
        return wantarray ? @ret : $ret[0];
382}
383
384# _parse_timestamp -- Private
385#
386# Purpose:      Convert a timestamp string to an integer epoch value.
387#               Supports: raw epoch integer, ISO8601 UTC (YYYY-MM-DDTHH:MM:SSZ),
388#               space-separated (YYYY-MM-DD HH:MM:SS), date-only (YYYY-MM-DD).
389# Entry:        $_[0] -- Str, non-empty timestamp
390# Exit:         Int, epoch seconds
391# Side effects: none
392sub _parse_timestamp {
393
114
114
10210
        my $ts = $_[0];
394
395
114
100
100
230
        croak 'Invalid timestamp format for TimeTravel: (undef)'
396                unless defined $ts && length $ts;
397
398
111
280
        $ts =~ s/^\s+|\s+$//g;   # trim whitespace
399
400        # Raw epoch integer -- return unchanged
401
111
100
155
        return $ts if $ts =~ /^\d+$/;
402
403        # ISO8601 UTC: YYYY-MM-DDTHH:MM:SSZ
404
107
100
166
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})Z$/) {
405
100
158
                return timegm($6, $5, $4, $3, $2 - 1, $1);
406        }
407
408        # Space-separated: YYYY-MM-DD HH:MM:SS
409
7
100
12
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})\s+(\d{2}):(\d{2}):(\d{2})$/) {
410
2
5
                return timegm($6, $5, $4, $3, $2 - 1, $1);
411        }
412
413        # Date-only: YYYY-MM-DD interpreted as midnight UTC
414
5
100
11
        if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
415
2
6
                return timegm(0, 0, 0, $3, $2 - 1, $1);
416        }
417
418
3
20
        croak "Invalid timestamp format for TimeTravel: $ts";
419}
420
421# Backwards-compatible alias used in some older tests.
422
18
18
1854
sub _parse_datetime { _parse_timestamp(@_) }
423
424# _unit_to_seconds -- Private
425#
426# Purpose:      Convert (amount, unit) into a number of seconds.
427#               Unit is optional (raw seconds assumed if absent).
428# Entry:        $amount -- Int; $unit -- Str or undef
429# Exit:         Int, seconds
430# Side effects: none
431sub _unit_to_seconds {
432
44
44
6050
        my ($amount, $unit) = @_;
433
434
44
100
51
        return $amount unless defined $unit;
435
436
35
30
        my $key = lc $unit;
437        croak "Unknown time unit '$unit'"
438
35
100
57
                unless exists $SECONDS_PER_UNIT{$key};
439
440
32
42
        return $amount * $SECONDS_PER_UNIT{$key};
441}
442
443 - 471
=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
472
4731;