TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (3/3)
Approximate LCSAJ segments: 31
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package Test::Mockingbird::TimeTravel; 2: 3: use strict; 4: use warnings; 5: 6: use Carp qw(croak); 7: use Time::Local qw(timegm); 8: use Exporter 'import'; 9: 10: our @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). 22: my %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'. 35: our $ACTIVE = 0; # 1 when frozen, 0 when using real time 36: our $CURRENT_EPOCH = undef; # simulated time when frozen 37: our $BASE_EPOCH = undef; # epoch at the moment of freeze() 38: 39: =head1 NAME 40: 41: Test::Mockingbird::TimeTravel - Deterministic, controllable time for Perl tests 42: 43: =head1 VERSION 44: 45: Version 0.13 46: 47: =cut 48: 49: our $VERSION = '0.13'; 50: 51: =head1 SYNOPSIS 52: 53: use Test::Mockingbird::TimeTravel qw( 54: now freeze_time travel_to advance_time rewind_time 55: restore_all with_frozen_time 56: ); 57: 58: freeze_time('2025-01-01T00:00:00Z'); 59: is now(), 1735689600, 'time is frozen'; 60: 61: advance_time(2 => 'minutes'); 62: is now(), 1735689720, 'time advanced deterministically'; 63: 64: with_frozen_time '2025-01-02T12:00:00Z' => sub { 65: is now(), 1735819200, 'block sees overridden time'; 66: }; 67: 68: is now(), 1735689720, 'outer time restored after block'; 69: 70: restore_all(); 71: isnt now(), 1735689720, 'real time restored'; 72: 73: =head1 DESCRIPTION 74: 75: C<Test::Mockingbird::TimeTravel> provides a lightweight, deterministic 76: time-control layer for Perl tests. It does B<not> monkey-patch 77: C<CORE::time()>. Instead it provides a dedicated C<now()> function and a 78: small set of declarative operations that manipulate an internal frozen clock. 79: 80: =head1 LIMITATIONS 81: 82: =over 4 83: 84: =item C<now()> is not a drop-in for C<time()> 85: 86: Production code must call C<now()> for time control to take effect. Code 87: that calls C<CORE::time()>, C<POSIX::time()>, or C<Time::HiRes::time()> 88: directly is not affected. 89: 90: =item Fractional seconds not supported 91: 92: All timestamps are integer epoch seconds. Sub-second resolution is not 93: available. 94: 95: =item Thread safety 96: 97: C<$ACTIVE>, C<$CURRENT_EPOCH>, and C<$BASE_EPOCH> are package globals. 98: Concurrent threads that manipulate time state will race. 99: 100: =back 101: 102: =head1 METHODS 103: 104: =head2 now 105: 106: Return the current time. 107: 108: Returns C<$CURRENT_EPOCH> when frozen, C<CORE::time()> otherwise. 109: 110: =head3 API SPECIFICATION 111: 112: =head4 Input (Params::Validate::Strict schema) 113: 114: none 115: 116: =head4 Output (Returns::Set schema) 117: 118: returns: Int -- epoch seconds 119: 120: =head3 FORMAL SPECIFICATION 121: 122: now ≙ ($ACTIVE = 1 ⇒ returns $CURRENT_EPOCH) ∧ ($ACTIVE = 0 ⇒ returns CORE::time()) 123: 124: =cut 125: 126: sub now () { 127: return $ACTIVE ? $CURRENT_EPOCH : CORE::time();Mutants (Total: 2, Killed: 2, Survived: 0)
128: } 129: 130: =head2 freeze_time 131: 132: Freeze the clock at a specific timestamp. 133: 134: my $epoch = freeze_time('2025-01-01T00:00:00Z'); 135: 136: =head3 API SPECIFICATION 137: 138: =head4 Input (Params::Validate::Strict schema) 139: 140: $timestamp -- Str|Int (see _parse_timestamp for accepted formats) 141: 142: =head4 Output (Returns::Set schema) 143: 144: returns: Int -- frozen epoch 145: 146: =head3 MESSAGES 147: 148: "Invalid timestamp format for TimeTravel: ..." -- unrecognised format 149: 150: =head3 FORMAL SPECIFICATION 151: 152: freeze_time ≙ 153: ∀ ts : Str|Int • 154: post $ACTIVE' = 1 ∧ $CURRENT_EPOCH' = parse(ts) ∧ $BASE_EPOCH' = parse(ts) 155: 156: =cut 157: 158: sub freeze_time { 159: my ($ts) = @_; 160: $CURRENT_EPOCH = _parse_timestamp($ts); 161: $BASE_EPOCH = $CURRENT_EPOCH; 162: $ACTIVE = 1; 163: return $CURRENT_EPOCH;
Mutants (Total: 2, Killed: 2, Survived: 0)
164: } 165: 166: =head2 travel_to 167: 168: Move the frozen clock to a new timestamp without unfreezing. 169: 170: travel_to('2025-06-01T00:00:00Z'); 171: 172: Croaks if called while TimeTravel is inactive. 173: 174: =head3 API SPECIFICATION 175: 176: =head4 Input (Params::Validate::Strict schema) 177: 178: $timestamp -- Str|Int 179: 180: =head4 Output (Returns::Set schema) 181: 182: returns: Int -- new epoch 183: 184: =head3 MESSAGES 185: 186: "travel_to() called while TimeTravel is inactive" -- freeze_time() not called first 187: 188: =head3 FORMAL SPECIFICATION 189: 190: travel_to ≙ 191: pre $ACTIVE = 1 192: post $CURRENT_EPOCH' = parse(ts) ∧ $BASE_EPOCH unchanged ∧ $ACTIVE unchanged 193: 194: =cut 195: 196: sub travel_to { 197: croak 'travel_to() called while TimeTravel is inactive' unless $ACTIVE; 198: $CURRENT_EPOCH = _parse_timestamp($_[0]); 199: return $CURRENT_EPOCH;
Mutants (Total: 2, Killed: 2, Survived: 0)
200: } 201: 202: =head2 advance_time 203: 204: Advance the frozen clock by a duration. 205: 206: advance_time(30); # 30 seconds 207: advance_time(2 => 'minutes'); # 2 minutes 208: 209: Croaks if called while TimeTravel is inactive. 210: 211: =head3 API SPECIFICATION 212: 213: =head4 Input (Params::Validate::Strict schema) 214: 215: $amount -- Int 216: $unit -- Str, optional (second|minute|hour|day, plural forms ok) 217: 218: =head4 Output (Returns::Set schema) 219: 220: returns: Int -- new epoch 221: 222: =head3 MESSAGES 223: 224: "advance_time() called while TimeTravel is inactive" -- not frozen 225: "Unknown time unit '...'" -- unrecognised unit string 226: 227: =head3 FORMAL SPECIFICATION 228: 229: advance_time ≙ 230: pre $ACTIVE = 1 231: post $CURRENT_EPOCH' = $CURRENT_EPOCH + to_seconds(amount, unit) 232: 233: =cut 234: 235: sub advance_time { 236: croak 'advance_time() called while TimeTravel is inactive' unless $ACTIVE; 237: my ($amount, $unit) = @_; 238: $CURRENT_EPOCH += _unit_to_seconds($amount, $unit); 239: return $CURRENT_EPOCH;
Mutants (Total: 2, Killed: 2, Survived: 0)
240: } 241: 242: =head2 rewind_time 243: 244: Rewind the frozen clock by a duration. 245: 246: rewind_time(30); # 30 seconds 247: rewind_time(1 => 'hour'); # 1 hour 248: 249: Croaks if called while TimeTravel is inactive. 250: 251: =head3 API SPECIFICATION 252: 253: =head4 Input (Params::Validate::Strict schema) 254: 255: $amount -- Int 256: $unit -- Str, optional 257: 258: =head4 Output (Returns::Set schema) 259: 260: returns: Int -- new epoch 261: 262: =head3 MESSAGES 263: 264: "rewind_time() called while TimeTravel is inactive" -- not frozen 265: 266: =head3 FORMAL SPECIFICATION 267: 268: rewind_time ≙ 269: pre $ACTIVE = 1 270: post $CURRENT_EPOCH' = $CURRENT_EPOCH - to_seconds(amount, unit) 271: 272: =cut 273: 274: sub rewind_time { 275: croak 'rewind_time() called while TimeTravel is inactive' unless $ACTIVE; 276: my ($amount, $unit) = @_; 277: $CURRENT_EPOCH -= _unit_to_seconds($amount, $unit); 278: return $CURRENT_EPOCH;
Mutants (Total: 2, Killed: 2, Survived: 0)
279: } 280: 281: =head2 restore_all 282: 283: Return to real time and clear all frozen state. 284: 285: restore_all(); 286: 287: Idempotent. Called automatically by L<Test::Mockingbird::DeepMock>. 288: 289: =head3 API SPECIFICATION 290: 291: =head4 Input (Params::Validate::Strict schema) 292: 293: none 294: 295: =head4 Output (Returns::Set schema) 296: 297: returns: undef 298: 299: =head3 FORMAL SPECIFICATION 300: 301: restore_all ≙ 302: post $ACTIVE' = 0 ∧ $CURRENT_EPOCH' = undef ∧ $BASE_EPOCH' = undef 303: 304: =cut 305: 306: sub restore_all { 307: $ACTIVE = 0; 308: $CURRENT_EPOCH = undef; 309: $BASE_EPOCH = undef; 310: return; 311: } 312: 313: =head2 with_frozen_time 314: 315: Temporarily override time inside a code block, restoring previous state 316: afterward even if the block throws. 317: 318: with_frozen_time '2025-01-02T12:00:00Z' => sub { 319: is now(), 1735819200, 'block sees overridden time'; 320: }; 321: 322: Fully nestable. 323: 324: =head3 API SPECIFICATION 325: 326: =head4 Input (Params::Validate::Strict schema) 327: 328: $timestamp -- Str|Int 329: $code -- CodeRef 330: 331: =head4 Output (Returns::Set schema) 332: 333: returns: Any -- whatever $code returns 334: 335: =head3 MESSAGES 336: 337: "with_frozen_time() requires a coderef" -- second arg not a CodeRef 338: "with_frozen_time() requires a timestamp" -- first arg undefined 339: 340: =head3 FORMAL SPECIFICATION 341: 342: with_frozen_time ≙ 343: ∀ ts : Str|Int; code : CodeRef • 344: pre defined(ts) ∧ ref(code) = 'CODE' 345: post (save prev_state; freeze(ts); run code; restore prev_state) 346: ∧ exceptions rethrown 347: 348: =cut 349: 350: sub with_frozen_time { 351: my ($ts, $code) = @_; 352: 353: croak 'with_frozen_time() requires a coderef' 354: unless ref($code) eq 'CODE'; 355: 356: croak 'with_frozen_time() requires a timestamp' 357: unless defined $ts; 358: 359: # Save state so nested calls restore correctly 360: my ($prev_active, $prev_epoch, $prev_base) = 361: ($ACTIVE, $CURRENT_EPOCH, $BASE_EPOCH); 362: 363: $CURRENT_EPOCH = _parse_timestamp($ts); 364: $BASE_EPOCH = $CURRENT_EPOCH; 365: $ACTIVE = 1; 366: 367: my (@ret, $err); 368: { 369: local $@; 370: @ret = eval { $code->() }; 371: $err = $@; 372: } 373: 374: $ACTIVE = $prev_active; 375: $CURRENT_EPOCH = $prev_epoch; 376: $BASE_EPOCH = $prev_base; 377: 378: # Re-throw as croak to stay consistent with the rest of this module 379: croak $err if $err; 380: 381: return wantarray ? @ret : $ret[0];
Mutants (Total: 2, Killed: 2, Survived: 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 392: sub _parse_timestamp { ●393 → 404 → 409 393: my $ts = $_[0]; 394: 395: croak 'Invalid timestamp format for TimeTravel: (undef)' 396: unless defined $ts && length $ts; 397: 398: $ts =~ s/^\s+|\s+$//g; # trim whitespace 399: 400: # Raw epoch integer -- return unchanged 401: return $ts if $ts =~ /^\d+$/;
Mutants (Total: 2, Killed: 2, Survived: 0)
402: 403: # ISO8601 UTC: YYYY-MM-DDTHH:MM:SSZ 404: if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})T(\d{2}):(\d{2}):(\d{2})Z$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
405: return timegm($6, $5, $4, $3, $2 - 1, $1);
Mutants (Total: 2, Killed: 2, Survived: 0)
406: } 407: 408: # Space-separated: YYYY-MM-DD HH:MM:SS ●409 → 409 → 414 409: if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})\s+(\d{2}):(\d{2}):(\d{2})$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
410: return timegm($6, $5, $4, $3, $2 - 1, $1);
Mutants (Total: 2, Killed: 2, Survived: 0)
411: } 412: 413: # Date-only: YYYY-MM-DD interpreted as midnight UTC ●414 → 414 → 418 414: if ($ts =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
415: return timegm(0, 0, 0, $3, $2 - 1, $1);
Mutants (Total: 2, Killed: 2, Survived: 0)
416: } 417: 418: croak "Invalid timestamp format for TimeTravel: $ts"; 419: } 420: 421: # Backwards-compatible alias used in some older tests. 422: 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 431: sub _unit_to_seconds { 432: my ($amount, $unit) = @_; 433: 434: return $amount unless defined $unit;
Mutants (Total: 2, Killed: 2, Survived: 0)
435: 436: my $key = lc $unit; 437: croak "Unknown time unit '$unit'" 438: unless exists $SECONDS_PER_UNIT{$key}; 439: 440: return $amount * $SECONDS_PER_UNIT{$key};
Mutants (Total: 2, Killed: 2, Survived: 0)
441: } 442: 443: =head1 SUPPORT 444: 445: Please report bugs at L<https://github.com/nigelhorne/Test-Mockingbird/issues>. 446: 447: =head1 AUTHOR 448: 449: Nigel Horne, C<< <njh at nigelhorne.com> >> 450: 451: =head1 SEE ALSO 452: 453: =over 4 454: 455: =item * L<Test::Mockingbird> 456: 457: =item * L<Test::Mockingbird::DeepMock> 458: 459: =back 460: 461: =head1 REPOSITORY 462: 463: L<https://github.com/nigelhorne/Test-Mockingbird> 464: 465: =head1 LICENCE AND COPYRIGHT 466: 467: Copyright 2026 Nigel Horne. 468: 469: Usage is subject to GPL2 licence terms. 470: 471: =cut 472: 473: 1;