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