TER1 (Statement): 100.00%
TER2 (Branch): 95.52%
TER3 (LCSAJ): 100.0% (20/20)
Approximate LCSAJ segments: 135
● 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; 2: 3: use strict; 4: use warnings; 5: use 5.016003; 6: 7: # TODO: Add $ENV{TEST_MOCKINGBIRD_DEBUG} tracing flag that emits one line to 8: # STDERR on each mock/unmock/restore_all operation (name, type, caller 9: # location). diagnose_mocks() covers post-hoc inspection; this would add 10: # real-time per-operation tracing for troubleshooting complex stacking 11: # scenarios. Inspired by Function::Override's PERL_FUNCTION_OVERRIDE_DEBUG. 12: 13: use Carp qw(croak carp); 14: use Exporter 'import'; 15: use Scalar::Util (); 16: 17: # Internal type-name constants -- eliminate magic strings. 18: # These constants are used wherever a layer type is recorded in %mock_meta. 19: use constant { 20: _T_MOCK => 'mock', 21: _T_SPY => 'spy', 22: _T_INJECT => 'inject', 23: _T_MOCK_RETURN => 'mock_return', 24: _T_MOCK_EXCEPT => 'mock_exception', 25: _T_MOCK_SEQ => 'mock_sequence', 26: _T_MOCK_ONCE => 'mock_once', 27: _T_MOCK_SCOPED => 'mock_scoped', 28: _T_INTERCEPT_NEW => 'intercept_new', 29: _T_BEFORE => 'before', 30: _T_AFTER => 'after', 31: _T_AROUND => 'around', 32: _T_MOCK_CORE => 'mock_core', 33: }; 34: 35: our @EXPORT = qw( 36: mock 37: unmock 38: mock_scoped 39: mock_core 40: before 41: after 42: around 43: spy 44: inject 45: inject_all 46: intercept_new 47: restore 48: restore_all 49: mock_return 50: mock_exception 51: mock_sequence 52: mock_once 53: diagnose_mocks 54: diagnose_mocks_pretty 55: assert_call_order 56: clear_call_log 57: ); 58: 59: # $TYPE is set via 'local' by sugar functions before delegating to mock() 60: # or inject() so that diagnose_mocks() records the correct layer type. 61: # External modules (e.g. Test::Mockingbird::Async) use the same mechanism. 62: our $TYPE; 63: 64: # Internal mocking state -- module-level lexicals. 65: my %mocked; # full_method => [ stack of coderefs (or undef stubs) ] 66: my %mock_meta; # full_method => [ { type => ..., installed_at => ... }, ... ] 67: my @call_log; # ordered log of every spied call 68: 69: =head1 NAME 70: 71: Test::Mockingbird - Advanced mocking library for Perl with support for 72: dependency injection, spies, call ordering, constructor interception, and 73: async Future mocking 74: 75: =head1 VERSION 76: 77: Version 0.13 78: 79: =cut 80: 81: our $VERSION = '0.13'; 82: 83: =head1 SYNOPSIS 84: 85: use Test::Mockingbird; 86: 87: # Mocking (shorthand form) 88: mock 'My::Module::method' => sub { 'mocked' }; 89: 90: # Mocking (longhand form) 91: mock('My::Module', 'method', sub { 'mocked' }); 92: 93: # Spying 94: my $spy = spy 'My::Module::method'; 95: My::Module::method('arg1'); 96: my @calls = $spy->(); # ( ['My::Module::method', 'arg1'], ... ) 97: 98: # Dependency injection 99: inject 'My::Module::Dependency' => $mock_object; 100: 101: # Batch dependency injection 102: inject_all('My::Module', { 103: DB => $mock_db, 104: Logger => $mock_logger, 105: }); 106: 107: # Constructor interception 108: intercept_new 'My::Service' => $stub_obj; 109: intercept_new 'My::Service' => sub { My::Double->new(@_[1..$#_]) }; 110: 111: # Unmock one layer 112: unmock 'My::Module::method'; 113: 114: # Restore everything 115: restore_all(); 116: 117: # Call ordering 118: spy 'A::fetch'; 119: spy 'B::process'; 120: A::fetch(); 121: B::process(); 122: assert_call_order('A::fetch', 'B::process'); 123: clear_call_log(); 124: 125: =head1 DESCRIPTION 126: 127: Test::Mockingbird provides mocking, spying, dependency injection, 128: call-order verification, and constructor interception for Perl test suites. 129: 130: =head1 DIAGNOSTICS 131: 132: =head2 diagnose_mocks 133: 134: Returns a structured hashref of all active mock layers. 135: 136: =head2 diagnose_mocks_pretty 137: 138: Returns a human-readable multi-line string of all active mock layers. 139: 140: =head2 Diagnostic Metadata 141: 142: Each installed layer records: 143: 144: type -- category (mock, spy, inject, mock_return, ...) 145: installed_at -- file and line number of the outermost user call site 146: 147: =head1 LIMITATIONS 148: 149: =over 4 150: 151: =item C<< ->can() >> may return truthy after unmocking a never-existed method 152: 153: Perl's typeglob (GV) system auto-vivifies a GV entry the first time 154: C<\&{$full_method}> is called internally (in C<mock()>, C<spy()>, or 155: C<inject()>). After unmocking, this GV entry remains in the stash with an 156: "undefined sub" placeholder in the CODE slot. C<< Package->can('method') >> 157: tests the GV's existence in the stash, not whether the CODE slot is defined, 158: so it may still return a truthy value. 159: 160: To test whether a sub is callable, use C<defined(&Package::method)> rather 161: than C<< Package->can('method') >>. C<defined(&...)> correctly returns false 162: for the placeholder stub. Calling the stub dies with C<"Undefined subroutine">. 163: 164: Deleting the GV from the stash (via C<delete $stash{method}>) would make 165: C<< ->can() >> return false but would break subsequent mock/inject stacking: 166: compiled direct calls (C<Package::method()>) cache the GV at compile time, 167: so a new GV installed after a delete is invisible to those compiled calls. 168: 169: =item Prototype mismatch warning from C<spy()> 170: 171: C<spy()> installs its wrapper directly without going through C<mock()>, 172: so C<Scalar::Util::set_prototype> is not applied. Wrapping a prototyped 173: function with C<spy()> still emits a C<Prototype mismatch> warning. Use 174: C<mock()> with a delegating wrapper if warning-free wrapping is required. 175: 176: =item No nested deep_mock scopes 177: 178: L<Test::Mockingbird::DeepMock> calls C<restore_all()> at scope exit, which 179: removes every active mock. Nested C<deep_mock> blocks cause the inner exit 180: to also tear down the outer mocks. Do not nest C<deep_mock> calls. 181: 182: =item Thread safety 183: 184: The internal state (C<%mocked>, C<%mock_meta>, C<@call_log>) is per-process 185: lexical state. Concurrent threads that install and restore mocks will race. 186: Do not use this module in threaded test harnesses without external locking. 187: 188: =item Spy return value is a flat list 189: 190: C<spy()> and C<async_spy()> return a coderef that yields a flat list of 191: call records. A future version may return an arrayref to reduce stack 192: pressure; the API is not yet changed to avoid breaking callers. 193: 194: =item Private-function encapsulation 195: 196: Functions prefixed with C<_> are private by convention but are not enforced 197: at runtime (C<Sub::Private> is not activated). White-box tests in C<t/unit.t> 198: call private functions directly. If C<Sub::Private> enforcement is added, a 199: testing-interface export mechanism will be required. 200: 201: =back 202: 203: =encoding utf-8 204: 205: =head1 METHODS 206: 207: =head2 mock 208: 209: Replace a method with a coderef. 210: 211: mock('My::Module', 'method', sub { 'mocked' }); 212: mock 'My::Module::method' => sub { 'mocked' }; 213: 214: Mocks stack in LIFO order. Each C<mock()> call saves the current CODE slot 215: (or the auto-vivified undef stub if the method does not exist) and installs 216: the replacement. C<unmock()> pops one layer; C<restore_all()> drains all. 217: 218: If the original carries a Perl prototype, the same prototype is stamped onto 219: the replacement coderef before installation, suppressing C<Prototype mismatch> 220: warnings. 221: 222: =head3 API SPECIFICATION 223: 224: =head4 Input 225: 226: target -- Str, 'Pkg::method' or ('Pkg', 'method') 227: replacement -- CodeRef 228: 229: =head4 Output 230: 231: returns: undef 232: 233: =head3 MESSAGES 234: 235: "Package, method and replacement are required" -- target or coderef missing 236: 237: =cut 238: 239: sub mock { ●240 → 245 → 251 240: my ($arg1, $arg2, $arg3) = @_; 241: 242: my ($package, $method, $replacement); 243: 244: # Shorthand: 'Pkg::method' => $code (arg3 absent) 245: if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {Mutants (Total: 1, Killed: 1, Survived: 0)
246: ($package, $method, $replacement) = ($1, $2, $arg2); 247: } else { 248: ($package, $method, $replacement) = ($arg1, $arg2, $arg3); 249: } 250: ●251 → 271 → 273 251: croak 'Package, method and replacement are required for mocking' 252: unless $package && $method && $replacement; 253: 254: my $full_method = "${package}::${method}"; 255: 256: # Capture the current CODE slot (or the undef-stub if the method does 257: # not yet exist). We always capture via \& so that on restore we 258: # write back to the SAME GV that compiled direct calls hold, rather 259: # than deleting the GV and creating a new one that compiled ops miss. 260: my ($original, $orig_existed); 261: { 262: no strict 'refs'; ## no critic (ProhibitNoStrict) 263: $orig_existed = defined(&{$full_method}) ? 1 : 0; 264: $original = \&{$full_method}; 265: } 266: push @{ $mocked{$full_method} }, $original; 267: 268: # Stamp the prototype onto the replacement to avoid Perl warning about 269: # "Prototype mismatch" when the original had a prototype. 270: my $orig_proto = prototype($original); 271: if (defined $orig_proto) {
Mutants (Total: 1, Killed: 1, Survived: 0)
272: &Scalar::Util::set_prototype($replacement, $orig_proto); 273: } 274: 275: { 276: # 'redefine' suppresses "Subroutine ... redefined". 277: # 'prototype' suppresses "Prototype mismatch" -- that warning lives in 278: # a separate category and is not covered by 'redefine'. set_prototype() 279: # above should already make the prototypes equal, but on some Perl builds 280: # the GV-level check still fires before the CV slot is fully updated, so 281: # we suppress the warning here. 282: no warnings 'redefine', 'prototype'; 283: no strict 'refs'; ## no critic (ProhibitNoStrict) 284: *{$full_method} = $replacement; 285: } 286: 287: push @{ $mock_meta{$full_method} }, { 288: type => $TYPE // _T_MOCK, 289: installed_at => _caller_info(), 290: original_existed => $orig_existed, 291: }; 292: 293: return; 294: } 295: 296: =head2 unmock 297: 298: Restore the previous implementation of a mocked method (one layer). 299: 300: unmock('My::Module', 'method'); 301: unmock 'My::Module::method'; 302: 303: If the method did not exist before it was mocked, the original undef-stub 304: is restored so that calling the method dies with C<"Undefined subroutine">. 305: Note: C<< ->can() >> may still return truthy; use C<defined(&...)> to test 306: whether a method is callable. See L</LIMITATIONS>. 307: 308: =head3 API SPECIFICATION 309: 310: =head4 Input 311: 312: target -- Str, 'Pkg::method' or ('Pkg', 'method') 313: 314: =head4 Output 315: 316: returns: undef 317: 318: =head3 MESSAGES 319: 320: "Package and method are required for unmocking" -- target missing 321: 322: =cut 323: 324: sub unmock { ●325 → 328 → 334 325: my ($arg1, $arg2) = @_; 326: 327: my ($package, $method); 328: if (defined $arg1 && !defined $arg2 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
329: ($package, $method) = ($1, $2); 330: } else { 331: ($package, $method) = ($arg1, $arg2); 332: } 333: ●334 → 344 → 359 334: croak 'Package and method are required for unmocking' 335: unless $package && $method; 336: 337: my $full_method = "${package}::${method}"; 338: 339: # Nothing to do if this method was never mocked 340: return unless exists $mocked{$full_method} && @{ $mocked{$full_method} }; 341: 342: my $prev = pop @{ $mocked{$full_method} }; 343: 344: if (defined $prev) {
Mutants (Total: 1, Killed: 1, Survived: 0)
345: no warnings 'redefine'; 346: no strict 'refs'; ## no critic (ProhibitNoStrict) 347: *{$full_method} = $prev; 348: } elsif ($full_method =~ /^CORE::GLOBAL::/) { 349: # No prior CORE::GLOBAL override existed (mock_core pushed undef). 350: # Delete the stash entry so the real CORE builtin is reachable. 351: my ($bname) = ($full_method =~ /::([^:]+)$/); 352: no strict 'refs'; ## no critic (ProhibitNoStrict) 353: delete $CORE::GLOBAL::{$bname}; 354: } 355: 356: # Pop exactly one meta entry to mirror the mock stack. 357: # Earlier code deleted the entire key; that wiped meta for all layers 358: # still on the stack after a partial unmock. ●359 → 362 → 367 359: pop @{ $mock_meta{$full_method} }; 360: 361: # Clean up empty tracking structures 362: unless (@{ $mocked{$full_method} }) {
Mutants (Total: 1, Killed: 1, Survived: 0)
363: delete $mocked{$full_method}; 364: delete $mock_meta{$full_method}; 365: } 366: 367: return; 368: } 369: 370: =head2 before 371: 372: Run a hook before a method, then call the original and return its value. 373: 374: before 'My::Module::method' => sub { my @args = @_; ... }; 375: before('My::Module', 'method', sub { ... }); 376: 377: The hook receives the same C<@_> that the original would have received. Its 378: return value is discarded. The original is always called and its return value 379: is passed to the caller unchanged. Context (list / scalar / void) is 380: preserved. 381: 382: Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer, 383: C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as 384: C<'before'>. 385: 386: =head3 API SPECIFICATION 387: 388: =head4 Input 389: 390: target -- Str, 'Pkg::method' or ('Pkg', 'method') 391: hook -- CodeRef; receives (@original_args), return value discarded 392: 393: =head4 Output 394: 395: returns: undef 396: 397: =head3 MESSAGES 398: 399: "Package, method and hook are required for before()" -- target or hook missing or non-CODE 400: 401: =cut 402: 403: sub before { ●404 → 407 → 413 404: my ($arg1, $arg2, $arg3) = @_; 405: 406: my ($package, $method, $hook); 407: if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
408: ($package, $method, $hook) = ($1, $2, $arg2); 409: } else { 410: ($package, $method, $hook) = ($arg1, $arg2, $arg3); 411: } 412: 413: croak 'Package, method and hook are required for before()' 414: unless $package && $method && ref($hook) eq 'CODE'; 415: 416: my $full_method = "${package}::${method}"; 417: my $orig; 418: { 419: no strict 'refs'; ## no critic (ProhibitNoStrict) 420: $orig = \&{$full_method}; 421: } 422: 423: local $TYPE = _T_BEFORE; 424: mock($package, $method, sub { 425: my @args = @_; 426: $hook->(@args); 427: if (wantarray) {
Mutants (Total: 1, Killed: 1, Survived: 0)
428: return $orig->(@args);
Mutants (Total: 2, Killed: 2, Survived: 0)
429: } elsif (defined wantarray) { 430: return scalar $orig->(@args);
Mutants (Total: 2, Killed: 2, Survived: 0)
431: } else { 432: $orig->(@args); 433: return; 434: } 435: }); 436: 437: return; 438: } 439: 440: =head2 after 441: 442: Run a hook after a method and return the original's value. 443: 444: after 'My::Module::method' => sub { my @args = @_; ... }; 445: after('My::Module', 'method', sub { ... }); 446: 447: The original is called first. Its return value is captured, then the hook is 448: called with the same C<@_> that the original received. The hook's return 449: value is discarded and the original's return value is passed to the caller 450: unchanged. Context (list / scalar / void) is preserved. 451: 452: If the original throws, the exception propagates immediately and the hook is 453: B<not> called. Use C<around()> if you need to run code unconditionally after 454: the original. 455: 456: Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer, 457: C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as 458: C<'after'>. 459: 460: =head3 API SPECIFICATION 461: 462: =head4 Input 463: 464: target -- Str, 'Pkg::method' or ('Pkg', 'method') 465: hook -- CodeRef; receives (@original_args), return value discarded 466: 467: =head4 Output 468: 469: returns: undef 470: 471: =head3 MESSAGES 472: 473: "Package, method and hook are required for after()" -- target or hook missing or non-CODE 474: 475: =cut 476: 477: sub after { ●478 → 481 → 487 478: my ($arg1, $arg2, $arg3) = @_; 479: 480: my ($package, $method, $hook); 481: if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
482: ($package, $method, $hook) = ($1, $2, $arg2); 483: } else { 484: ($package, $method, $hook) = ($arg1, $arg2, $arg3); 485: } 486: 487: croak 'Package, method and hook are required for after()' 488: unless $package && $method && ref($hook) eq 'CODE'; 489: 490: my $full_method = "${package}::${method}"; 491: my $orig; 492: { 493: no strict 'refs'; ## no critic (ProhibitNoStrict) 494: $orig = \&{$full_method}; 495: } 496: 497: local $TYPE = _T_AFTER; 498: mock($package, $method, sub { 499: my @args = @_; 500: if (wantarray) {
Mutants (Total: 1, Killed: 1, Survived: 0)
501: my @ret = $orig->(@args); 502: $hook->(@args); 503: return @ret;
Mutants (Total: 2, Killed: 2, Survived: 0)
504: } elsif (defined wantarray) { 505: my $ret = $orig->(@args); 506: $hook->(@args); 507: return $ret;
Mutants (Total: 2, Killed: 2, Survived: 0)
508: } else { 509: $orig->(@args); 510: $hook->(@args); 511: return; 512: } 513: }); 514: 515: return; 516: } 517: 518: =head2 around 519: 520: Replace a method with a hook that receives the original coderef as its first 521: argument. 522: 523: around 'My::Module::method' => sub { 524: my ($orig, @args) = @_; 525: my $result = $orig->(@args); # call original 526: return $result * 2; # modify return value 527: }; 528: 529: around('My::Module', 'method', sub { 530: my ($orig, @args) = @_; 531: return $orig->(@args); 532: }); 533: 534: The hook receives C<($orig_coderef, @original_args)>. It may call C<$orig> 535: zero or more times with any arguments. Its return value becomes the return 536: value of the method. The hook is responsible for context handling when that 537: matters. 538: 539: C<around()> is the preferred alternative to C<mock()> when you need to call 540: through to the original: it captures the original and passes it as the first 541: argument, avoiding the boilerplate of a separate C<\&{...}> capture. 542: 543: Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer, 544: C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as 545: C<'around'>. 546: 547: =head3 API SPECIFICATION 548: 549: =head4 Input 550: 551: target -- Str, 'Pkg::method' or ('Pkg', 'method') 552: hook -- CodeRef; receives ($orig_coderef, @original_args) 553: 554: =head4 Output 555: 556: returns: undef 557: 558: =head3 MESSAGES 559: 560: "Package, method and hook are required for around()" -- target or hook missing or non-CODE 561: 562: =cut 563: 564: sub around { ●565 → 568 → 574 565: my ($arg1, $arg2, $arg3) = @_; 566: 567: my ($package, $method, $hook); 568: if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
569: ($package, $method, $hook) = ($1, $2, $arg2); 570: } else { 571: ($package, $method, $hook) = ($arg1, $arg2, $arg3); 572: } 573: 574: croak 'Package, method and hook are required for around()' 575: unless $package && $method && ref($hook) eq 'CODE'; 576: 577: my $full_method = "${package}::${method}"; 578: my $orig; 579: { 580: no strict 'refs'; ## no critic (ProhibitNoStrict) 581: $orig = \&{$full_method}; 582: } 583: 584: local $TYPE = _T_AROUND; 585: mock($package, $method, sub { $hook->($orig, @_) }); 586: 587: return; 588: } 589: 590: =head2 mock_scoped 591: 592: Create a scoped mock that restores automatically when the guard goes out of scope. 593: 594: =head3 Single-method forms 595: 596: my $g = mock_scoped 'My::Module::method' => sub { 'mocked' }; 597: my $g = mock_scoped('My::Module', 'method', sub { ... }); 598: 599: =head3 Multi-method forms 600: 601: my $g = mock_scoped('My::Module', 602: fetch => sub { 'mocked_fetch' }, 603: save => sub { 'mocked_save' }, 604: ); 605: 606: my $g = mock_scoped( 607: 'My::Module::fetch' => sub { 'mocked_fetch' }, 608: 'Other::Module::save' => sub { 'mocked_save' }, 609: ); 610: 611: All mocked methods are restored when C<$g> goes out of scope. 612: 613: =head3 API SPECIFICATION 614: 615: =head4 Input 616: 617: args -- four recognised forms (see above) 618: 619: =head4 Output 620: 621: returns: Test::Mockingbird::Guard 622: 623: =head3 MESSAGES 624: 625: "mock_scoped: unrecognised argument form" -- none of the four forms matched 626: "mock_scoped: expected coderef for '$target'" -- non-CODE value provided 627: 628: =cut 629: 630: sub mock_scoped { ●631 → 635 → 666 631: my @args = @_; 632: 633: my @pairs; 634: 635: if (@args == 2 && ref($args[1]) eq 'CODE') {
Mutants (Total: 2, Killed: 2, Survived: 0)
636: my ($pkg, $meth) = _parse_target($args[0]); 637: push @pairs, [ $pkg, $meth, $args[1] ]; 638: 639: } elsif (@args == 3 && !ref($args[1]) && ref($args[2]) eq 'CODE') {
Mutants (Total: 1, Killed: 1, Survived: 0)
640: push @pairs, [ $args[0], $args[1], $args[2] ]; 641: 642: } elsif (@args >= 4 && (@args % 2) == 0 && ref($args[1]) eq 'CODE') {
Mutants (Total: 4, Killed: 4, Survived: 0)
643: my @a = @args; 644: while (@a) { 645: my ($target, $code) = splice @a, 0, 2; 646: croak "mock_scoped: expected coderef for '$target'" 647: unless ref($code) eq 'CODE'; 648: my ($pkg, $meth) = _parse_target($target); 649: push @pairs, [ $pkg, $meth, $code ]; 650: } 651: 652: } elsif (@args >= 5 && (@args % 2) == 1 && ref($args[2]) eq 'CODE') {
Mutants (Total: 4, Killed: 4, Survived: 0)
653: my @a = @args; 654: my $pkg = shift @a; 655: while (@a) { 656: my ($meth, $code) = splice @a, 0, 2; 657: croak "mock_scoped: expected coderef for method '$meth'" 658: unless ref($code) eq 'CODE'; 659: push @pairs, [ $pkg, $meth, $code ]; 660: } 661: 662: } else { 663: croak 'mock_scoped: unrecognised argument form'; 664: } 665: 666: my @full_methods; 667: { 668: local $TYPE = _T_MOCK_SCOPED; 669: for my $pair (@pairs) { 670: my ($pkg, $meth, $code) = @{$pair}; 671: mock($pkg, $meth, $code); 672: push @full_methods, "${pkg}::${meth}"; 673: } 674: } 675: 676: return Test::Mockingbird::Guard->new(@full_methods);
Mutants (Total: 2, Killed: 2, Survived: 0)
677: } 678: 679: =head2 spy 680: 681: Wrap a method so that every call is recorded. The original method is still 682: called and its return value is passed back to the caller. 683: 684: my $spy = spy 'My::Module::method'; 685: My::Module::method('arg'); 686: my @calls = $spy->(); # ( ['My::Module::method', 'arg'], ... ) 687: restore_all(); 688: 689: Returns a coderef that, when invoked, returns the list of captured call 690: records. Each record is an arrayref C<[ $full_method, @args ]>. 691: 692: =head3 API SPECIFICATION 693: 694: =head4 Input 695: 696: target -- Str, 'Pkg::method' or ('Pkg', 'method') 697: 698: =head4 Output 699: 700: returns: CodeRef # yields list of call records on invocation 701: 702: =head3 MESSAGES 703: 704: "Package and method are required for spying" -- target missing or incomplete 705: 706: =cut 707: 708: sub spy { ●709 → 740 → 742 709: my ($package, $method) = _parse_target(@_); 710: 711: croak 'Package and method are required for spying' 712: unless $package && $method; 713: 714: my $full_method = "${package}::${method}"; 715: 716: # Capture current implementation (or undef stub if none exists). 717: # We never delete the GV; we always restore by assigning back to *{}, 718: # preserving the GV so compiled direct calls remain valid. 719: my ($orig, $orig_existed); 720: { 721: no strict 'refs'; ## no critic (ProhibitNoStrict) 722: $orig_existed = defined(&{$full_method}) ? 1 : 0; 723: $orig = \&{$full_method}; 724: } 725: push @{ $mocked{$full_method} }, $orig; 726: 727: my @calls; 728: 729: my $wrapper = sub { 730: push @calls, [ $full_method, @_ ]; 731: push @call_log, $full_method; 732: # FIXME: check for recursive calls 733: return $orig->(@_);
Mutants (Total: 2, Killed: 2, Survived: 0)
734: }; 735: 736: # Preserve the original's prototype to suppress "Prototype mismatch" 737: # warnings and ensure '_'-prototype functions (stat, lstat, etc.) bind 738: # $_ correctly at the call site when wrapped. 739: my $orig_proto = prototype($orig); 740: if (defined $orig_proto) {
741: &Scalar::Util::set_prototype($wrapper, $orig_proto); 742: } 743: 744: { 745: no warnings 'redefine', 'prototype'; 746: no strict 'refs'; ## no critic (ProhibitNoStrict) 747: *{$full_method} = $wrapper; 748: } 749: 750: push @{ $mock_meta{$full_method} }, { 751: type => _T_SPY, 752: installed_at => _caller_info(), 753: original_existed => $orig_existed, 754: }; 755: 756: return sub { @calls };Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_740_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
757: } 758: 759: =head2 inject 760: 761: Inject a mock dependency into a package. 762: 763: inject('My::Module', 'Dependency', $mock_object); 764: inject 'My::Module::Dependency' => $mock_object; 765: 766: Injecting C<undef> is valid; use argument count (not definedness of the 767: third argument) to distinguish shorthand from longhand. 768: 769: =head3 API SPECIFICATION 770: 771: =head4 Input 772: 773: package -- Str 774: dependency -- Str 775: value -- Any (including undef) 776: 777: =head4 Output 778: 779: returns: undef 780: 781: =head3 MESSAGES 782: 783: "Package and dependency are required for injection" -- missing name 784: 785: =cut 786: 787: sub inject { ●788 → 793 → 799 788: my ($package, $dependency, $mock_object); 789: 790: # Discriminate shorthand (2 args) from longhand (3 args) by argument 791: # count rather than definedness of the third arg so that inject(Pkg, 792: # Dep, undef) -- injecting undef -- is correctly handled. 793: if (@_ == 2 && defined $_[0] && $_[0] =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 2, Killed: 2, Survived: 0)
794: ($package, $dependency, $mock_object) = ($1, $2, $_[1]); 795: } else { 796: ($package, $dependency, $mock_object) = @_; 797: } 798: 799: croak 'Package and dependency are required for injection' 800: unless $package && $dependency; 801: 802: my $full = "${package}::${dependency}"; 803: 804: my ($orig, $orig_existed); 805: { 806: no strict 'refs'; ## no critic (ProhibitNoStrict) 807: $orig_existed = defined(&{$full}) ? 1 : 0; 808: $orig = \&{$full}; 809: } 810: push @{ $mocked{$full} }, $orig; 811: 812: my $wrapper = sub { $mock_object }; 813: 814: { 815: no warnings 'redefine'; 816: no strict 'refs'; ## no critic (ProhibitNoStrict) 817: *{$full} = $wrapper; 818: } 819: 820: # inject() respects $TYPE so that inject_all() or any future wrapper 821: # can label the layer differently (though 'inject' is the sensible default). 822: push @{ $mock_meta{$full} }, { 823: type => $TYPE // _T_INJECT, 824: installed_at => _caller_info(), 825: original_existed => $orig_existed, 826: }; 827: 828: return; 829: } 830: 831: =head2 inject_all 832: 833: Inject multiple dependencies into a package in one call. 834: 835: inject_all('My::Service', { 836: DB => $mock_db, 837: Logger => $mock_logger, 838: }); 839: 840: An empty hashref is a no-op. Each pair is equivalent to a separate 841: C<inject()> call and participates in the same mock stack. 842: 843: =head3 API SPECIFICATION 844: 845: =head4 Input 846: 847: package -- Str 848: dependencies -- HashRef 849: 850: =head4 Output 851: 852: returns: undef 853: 854: =head3 MESSAGES 855: 856: "inject_all requires a package name" -- undef or empty package 857: "inject_all requires a hashref of dependencies" -- second arg not a HashRef 858: 859: =cut 860: 861: sub inject_all { 862: my ($package, $deps) = @_; 863: 864: croak 'inject_all requires a package name' 865: unless defined $package && length $package; 866: 867: croak 'inject_all requires a hashref of dependencies' 868: unless ref $deps eq 'HASH'; 869: 870: inject($package, $_, $deps->{$_}) for keys %$deps; 871: 872: return; 873: } 874: 875: =head2 intercept_new 876: 877: Intercept the C<new> constructor of a class. 878: 879: intercept_new 'My::Service' => $stub_obj; 880: intercept_new 'My::Service' => sub { My::Double->new(@_[1..$#_]) }; 881: 882: When given a plain value (including undef), every call to 883: C<< My::Service->new >> returns that value. When given a coderef, every 884: call invokes the coderef with the original arguments (including the class 885: name as the first argument) and returns its result. 886: 887: This is a thin wrapper around C<mock()>; C<restore_all()>, C<unmock()>, 888: and C<diagnose_mocks()> all work identically. 889: 890: =head3 API SPECIFICATION 891: 892: =head4 Input 893: 894: class -- Str (non-empty) 895: factory -- Any; CodeRef invoked per call, or scalar returned verbatim 896: 897: =head4 Output 898: 899: returns: undef 900: 901: =head3 MESSAGES 902: 903: "intercept_new requires a class name" -- undef/empty class 904: "intercept_new requires a replacement object or coderef" -- factory missing 905: 906: =cut 907: 908: sub intercept_new { 909: my ($class, $factory) = @_; 910: 911: croak 'intercept_new requires a class name' 912: unless defined $class && length $class; 913: croak 'intercept_new requires a replacement object or coderef' 914: if @_ < 2;
Mutants (Total: 3, Killed: 3, Survived: 0)
915: 916: my $replacement = ref($factory) eq 'CODE' 917: ? $factory 918: : sub { $factory }; 919: 920: local $TYPE = _T_INTERCEPT_NEW; 921: mock("${class}::new", $replacement); 922: 923: return; 924: } 925: 926: =head2 mock_core 927: 928: Override a CORE Perl builtin globally via C<CORE::GLOBAL>. 929: 930: # Intercept 'warn' for code compiled after this point 931: mock_core 'warn' => sub { 932: my ($call_warn, @msgs) = @_; 933: push @captured, @msgs; # capture without emitting 934: }; 935: 936: # Call through to the real builtin via $call_builtin 937: mock_core 'stat' => sub { 938: my ($call_stat, $file) = @_; 939: return $call_stat->($file); # delegates to CORE::stat 940: }; 941: 942: unmock 'CORE::GLOBAL::warn'; # peel one layer 943: restore_all(); # drain all layers 944: 945: The replacement receives C<($call_builtin, @original_args)>, mirroring the 946: C<around()> API. C<$call_builtin> is a coderef that calls C<CORE::$name> 947: directly, bypassing any other C<CORE::GLOBAL> override. 948: 949: The override is installed in C<CORE::GLOBAL::$name>, which is Perl's 950: documented mechanism for intercepting named builtins. It affects all 951: packages globally. 952: 953: B<Compile-time semantics:> C<CORE::GLOBAL> overrides are visible to code 954: compiled I<after> the override is installed. To intercept calls in a module 955: under test, install the mock I<before> loading that module (a C<BEGIN> block 956: works). Already-compiled call sites (including direct calls in the current 957: test file) are not affected at runtime. Use string C<eval> when you need 958: code compiled in the same test run to see the override. 959: 960: The wrapper carries the same prototype as C<CORE::$name> so that call-site 961: argument binding (such as the C<_> prototype that reads C<$_> when no 962: argument is given) is preserved. 963: 964: Participates in the same LIFO mock stack as C<mock()>. C<unmock>, 965: C<restore()>, and C<restore_all()> accept C<'CORE::GLOBAL::$name'> as the 966: target. C<diagnose_mocks()> records the layer type as C<'mock_core'>. 967: 968: B<Limitation:> builtins whose prototype begins with C<&> (C<sort>, C<map>, 969: C<grep>) require a literal code block at the call site and cannot be wrapped. 970: 971: =head3 API SPECIFICATION 972: 973: =head4 Input 974: 975: name -- Str, CORE builtin name (no 'CORE::' prefix required) 976: replacement -- CodeRef; receives ($call_builtin, @original_args) 977: 978: =head4 Output 979: 980: returns: undef 981: 982: =head3 MESSAGES 983: 984: "mock_core requires a builtin name and a replacement coderef" -- wrong arg types 985: "mock_core: '$name' is not a valid identifier" -- name has punctuation 986: "mock_core: '$name' is not an overridable Perl builtin" -- unknown builtin 987: "mock_core: cannot build CORE::$name delegator: ..." -- eval failed 988: 989: =cut 990: 991: sub mock_core { 992: my ($name, $replacement) = @_; 993: 994: croak 'mock_core requires a builtin name and a replacement coderef' 995: unless defined $name && ref($replacement) eq 'CODE'; 996: 997: $name =~ s/^CORE:://; # tolerate an optional 'CORE::' prefix 998: 999: croak "mock_core: '$name' is not a valid identifier" 1000: unless $name =~ /^\w+$/; 1001: croak "mock_core: '$name' is not an overridable Perl builtin" 1002: unless _is_core_overridable($name); 1003: 1004: my $core_proto = eval { my $p = prototype("CORE::$name"); $p }; 1005: 1006: # Build a delegator that calls CORE::$name directly. Must be eval'd 1007: # because CORE:: names are compile-time constructs -- no runtime coderef 1008: # exists. Calling CORE:: directly bypasses any other CORE::GLOBAL override. 1009: # For '_' prototype (e.g. stat), pass $_[0] explicitly to avoid the 1010: # "Array passed to stat will be coerced to a scalar" compiler warning that 1011: # fires when @_ is passed to a single-arg builtin. 1012: my $args = (defined $core_proto && $core_proto eq '_') ? '$_[0]' : '@_'; 1013: my $call_core = eval "sub { no warnings 'syntax'; CORE::$name($args) }"; ## no critic (ProhibitStringyEval) 1014: croak "mock_core: cannot build CORE::$name delegator: $@" if $@; 1015: 1016: # Wrap in an around-style closure and stamp the CORE prototype onto it 1017: # so call-site argument binding (e.g. '_' reads $_ when arg omitted) works. 1018: # List-op builtins (warn, die, print ...) have no traditional prototype 1019: # string (prototype("CORE::warn") returns undef), but Perl's CORE::GLOBAL 1020: # mechanism expects the override to carry '@'. Use '@' as the fallback so 1021: # the wrapper's prototype matches and suppresses "Prototype mismatch" at 1022: # eval-compile time. 1023: my $wrapper = sub { $replacement->($call_core, @_) }; 1024: my $effective_proto = defined($core_proto) ? $core_proto : '@'; 1025: &Scalar::Util::set_prototype($wrapper, $effective_proto); 1026: 1027: # Install in CORE::GLOBAL -- Perl's documented mechanism for global 1028: # builtin overrides. Track under the full name so unmock/restore_all work. 1029: my $full = "CORE::GLOBAL::$name"; 1030: 1031: my ($orig, $orig_existed); 1032: { 1033: no strict 'refs'; ## no critic (ProhibitNoStrict) 1034: $orig_existed = defined(&{$full}) ? 1 : 0; 1035: # When no prior override existed, push undef rather than \&{$full}. 1036: # \&{$full} auto-vivifies the stash entry and returns an undef-stub CV. 1037: # Reinstating that stub on restore would leave a CORE::GLOBAL entry 1038: # whose non-NULL CV pointer makes Perl treat it as an active override, 1039: # preventing fallback to the real builtin. _drain_and_restore detects 1040: # undef and deletes the stash entry instead. 1041: $orig = $orig_existed ? \&{$full} : undef; 1042: } 1043: push @{ $mocked{$full} }, $orig; 1044: 1045: { 1046: no warnings 'redefine', 'prototype'; 1047: no strict 'refs'; ## no critic (ProhibitNoStrict) 1048: *{$full} = $wrapper; 1049: } 1050: 1051: push @{ $mock_meta{$full} }, { 1052: type => $TYPE // _T_MOCK_CORE, 1053: installed_at => _caller_info(), 1054: original_existed => $orig_existed, 1055: }; 1056: 1057: return; 1058: } 1059: 1060: =head2 restore_all 1061: 1062: Restore all mocked methods and injected dependencies. 1063: 1064: restore_all(); # restore everything 1065: restore_all 'My::Module'; # restore only My::Module's mocks 1066: 1067: When called with a package name, only mocks whose fully-qualified names 1068: begin with that package are restored. The call-order log is pruned to 1069: remove entries for the restored package. 1070: 1071: =head3 API SPECIFICATION 1072: 1073: =head4 Input 1074: 1075: package -- Str, optional 1076: 1077: =head4 Output 1078: 1079: returns: undef 1080: 1081: =cut 1082: 1083: sub restore_all { ●1084 → 1086 → 1105 1084: my $arg = $_[0]; 1085: 1086: if (defined $arg) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1087: my $package = $arg; 1088: 1089: for my $full_method (keys %mocked) { 1090: next unless $full_method =~ /^\Q$package\E::/; 1091: _drain_and_restore($full_method); 1092: # _drain_and_restore explicitly skips hash cleanup; do it here 1093: # to match the behaviour of the global form (%mocked = (); etc.). 1094: delete $mocked{$full_method}; 1095: delete $mock_meta{$full_method}; 1096: } 1097: 1098: # Remove call_log entries for the restored package 1099: @call_log = grep { $_ !~ /^\Q$package\E::/ } @call_log; 1100: 1101: return; 1102: } 1103: 1104: # Global restore: revert every tracked method to its saved state 1105: _drain_and_restore($_) for keys %mocked; 1106: 1107: %mocked = (); 1108: %mock_meta = (); 1109: @call_log = (); 1110: 1111: return; 1112: } 1113: 1114: =head2 restore 1115: 1116: Restore all mock layers for a single method target. 1117: 1118: restore 'My::Module::method'; 1119: 1120: If the method was never mocked this is a no-op. 1121: 1122: =head3 API SPECIFICATION 1123: 1124: =head4 Input 1125: 1126: target -- Str 1127: 1128: =head4 Output 1129: 1130: returns: undef 1131: 1132: =head3 MESSAGES 1133: 1134: "restore requires a target" -- undef target 1135: 1136: =cut 1137: 1138: sub restore { 1139: my $target = $_[0]; 1140: 1141: croak 'restore requires a target' unless defined $target; 1142: 1143: my ($package, $method) = _parse_target($target); 1144: my $full_method = "${package}::${method}"; 1145: 1146: return unless exists $mocked{$full_method}; 1147: 1148: _drain_and_restore($full_method); 1149: delete $mocked{$full_method}; 1150: delete $mock_meta{$full_method}; 1151: 1152: return; 1153: } 1154: 1155: =head2 mock_return 1156: 1157: Mock a method to always return a fixed value. 1158: 1159: mock_return 'My::Module::method' => 42; 1160: 1161: =head3 API SPECIFICATION 1162: 1163: =head4 Input 1164: 1165: target -- Str 1166: value -- Any 1167: 1168: =head4 Output 1169: 1170: returns: undef 1171: 1172: =head3 MESSAGES 1173: 1174: "mock_return requires a target and a value" -- target undefined 1175: 1176: =cut 1177: 1178: sub mock_return { 1179: my ($target, $value) = @_; 1180: 1181: croak 'mock_return requires a target and a value' unless defined $target; 1182: 1183: local $TYPE = _T_MOCK_RETURN; 1184: mock $target => sub { $value }; 1185: 1186: return; 1187: } 1188: 1189: =head2 mock_exception 1190: 1191: Mock a method to always throw an exception. 1192: 1193: mock_exception 'My::Module::method' => 'something went wrong'; 1194: 1195: =head3 API SPECIFICATION 1196: 1197: =head4 Input 1198: 1199: target -- Str 1200: message -- Str 1201: 1202: =head4 Output 1203: 1204: returns: undef 1205: 1206: =head3 MESSAGES 1207: 1208: "mock_exception requires a target and an exception message" -- either missing 1209: 1210: =cut 1211: 1212: sub mock_exception { 1213: my ($target, $message) = @_; 1214: 1215: croak 'mock_exception requires a target and an exception message' 1216: unless defined $target && defined $message; 1217: 1218: local $TYPE = _T_MOCK_EXCEPT; 1219: mock $target => sub { croak $message }; 1220: 1221: return; 1222: } 1223: 1224: =head2 mock_sequence 1225: 1226: Mock a method to return a sequence of values over successive calls. 1227: The last value repeats when the sequence is exhausted. 1228: 1229: mock_sequence 'My::Module::method' => (1, 2, 3); 1230: 1231: =head3 API SPECIFICATION 1232: 1233: =head4 Input 1234: 1235: target -- Str 1236: values -- Array (one or more) 1237: 1238: =head4 Output 1239: 1240: returns: undef 1241: 1242: =head3 MESSAGES 1243: 1244: "mock_sequence requires a target and at least one value" -- empty value list 1245: 1246: =cut 1247: 1248: sub mock_sequence { 1249: my ($target, @values) = @_; 1250: 1251: croak 'mock_sequence requires a target and at least one value' 1252: unless defined $target && @values; 1253: 1254: my @queue = @values; 1255: 1256: local $TYPE = _T_MOCK_SEQ; 1257: mock $target => sub { 1258: return $queue[0] if @queue == 1;
Mutants (Total: 3, Killed: 3, Survived: 0)
1259: return shift @queue;
Mutants (Total: 2, Killed: 2, Survived: 0)
1260: }; 1261: 1262: return; 1263: } 1264: 1265: =head2 mock_once 1266: 1267: Install a mock that fires exactly once. After the first call the previous 1268: implementation is automatically restored. 1269: 1270: mock_once 'My::Module::method' => sub { 'temporary' }; 1271: 1272: =head3 API SPECIFICATION 1273: 1274: =head4 Input 1275: 1276: target -- Str 1277: code -- CodeRef 1278: 1279: =head4 Output 1280: 1281: returns: undef 1282: 1283: =head3 MESSAGES 1284: 1285: "mock_once requires a target and a coderef" -- missing or non-CODE factory 1286: 1287: =head3 PSEUDOCODE 1288: 1289: parse target → (package, method) 1290: wrapper = sub { 1291: result = code(@_) 1292: unmock(package, method) -- pop this very layer 1293: return result 1294: } 1295: install wrapper via mock() with TYPE='mock_once' 1296: 1297: =cut 1298: 1299: sub mock_once { 1300: my ($target, $code) = @_; 1301: 1302: croak 'mock_once requires a target and a coderef' 1303: unless defined $target && ref($code) eq 'CODE'; 1304: 1305: my ($package, $method) = _parse_target($target); 1306: 1307: my $wrapper = sub { 1308: my @result = $code->(@_); 1309: Test::Mockingbird::unmock($package, $method); 1310: return wantarray ? @result : $result[0];
Mutants (Total: 2, Killed: 2, Survived: 0)
1311: }; 1312: 1313: local $TYPE = _T_MOCK_ONCE; 1314: mock $target => $wrapper; 1315: 1316: return; 1317: } 1318: 1319: =head2 assert_call_order 1320: 1321: Assert that the named methods were called in left-to-right order. 1322: 1323: assert_call_order('A::fetch', 'B::process', 'C::save'); 1324: 1325: Produces one TAP ok/not-ok line and returns a boolean. Intervening calls 1326: to other methods are ignored. 1327: 1328: =head3 API SPECIFICATION 1329: 1330: =head4 Input 1331: 1332: methods -- Array of Str (two or more fully-qualified names) 1333: 1334: =head4 Output 1335: 1336: returns: Bool 1337: 1338: =head3 MESSAGES 1339: 1340: "assert_call_order requires at least two method names" -- fewer than two given 1341: 1342: =cut 1343: 1344: sub assert_call_order { ●1345 → 1351 → 1358 1345: my @expected = @_; 1346: 1347: croak 'assert_call_order requires at least two method names' 1348: unless @expected >= 2;
Mutants (Total: 3, Killed: 3, Survived: 0)
1349: 1350: my $pos = 0; 1351: for my $logged (@call_log) { 1352: if ($logged eq $expected[$pos]) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1353: $pos++; 1354: last if $pos == @expected;
Mutants (Total: 1, Killed: 1, Survived: 0)
1355: } 1356: } 1357: ●1358 → 1361 → 1370 1358: my $ok = ($pos == @expected);
Mutants (Total: 1, Killed: 1, Survived: 0)
1359: 1360: require Test::More; 1361: if ($ok) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1362: Test::More::pass("call order: " . join(' -> ', @expected)); 1363: } else { 1364: Test::More::fail("call order: " . join(' -> ', @expected)); 1365: Test::More::diag( 1366: "Expected '$expected[$pos]' next but it was not in the call log" 1367: ); 1368: } 1369: 1370: return $ok;
Mutants (Total: 2, Killed: 2, Survived: 0)
1371: } 1372: 1373: =head2 clear_call_log 1374: 1375: Clear the call-order log without restoring mocks or spies. 1376: 1377: clear_call_log(); 1378: 1379: C<restore_all()> also clears the log automatically. 1380: 1381: =head3 API SPECIFICATION 1382: 1383: =head4 Input 1384: 1385: none 1386: 1387: =head4 Output 1388: 1389: returns: undef 1390: 1391: =cut 1392: 1393: sub clear_call_log { 1394: @call_log = (); 1395: return; 1396: } 1397: 1398: # _record_call -- Private helper 1399: # 1400: # Purpose: Append a fully-qualified method name to the call-order log. 1401: # Used by Test::Mockingbird::Async to participate in 1402: # assert_call_order() without crossing the lexical boundary of 1403: # @call_log. 1404: # Entry: $_[0] -- Str, fully-qualified method name 1405: # Exit: undef 1406: # Side effects: Appends to @call_log 1407: sub _record_call { 1408: push @call_log, $_[0]; 1409: return; 1410: } 1411: 1412: =head2 diagnose_mocks 1413: 1414: Return a structured hashref of all currently active mock layers. 1415: 1416: my $diag = diagnose_mocks(); 1417: # $diag->{'My::Pkg::method'} = { 1418: # depth => 1, 1419: # layers => [ { type => 'mock_return', installed_at => '...' } ], 1420: # } 1421: 1422: =head3 API SPECIFICATION 1423: 1424: =head4 Input 1425: 1426: none 1427: 1428: =head4 Output 1429: 1430: returns: HashRef 1431: 1432: =cut 1433: 1434: sub diagnose_mocks { ●1435 → 1437 → 1448 1435: my %report; 1436: 1437: for my $full_method (sort keys %mocked) { 1438: my $layers = $mock_meta{$full_method} // []; 1439: $report{$full_method} = { 1440: depth => scalar @{ $mocked{$full_method} }, 1441: layers => [ @$layers ], 1442: # original_existed reflects whether the method existed before the 1443: # FIRST mock layer was installed (stored in the bottom-most meta entry) 1444: original_existed => (@$layers && $layers->[0]{original_existed}) ? 1 : 0, 1445: }; 1446: } 1447: 1448: return \%report;
Mutants (Total: 2, Killed: 2, Survived: 0)
1449: } 1450: 1451: =head2 diagnose_mocks_pretty 1452: 1453: Return a human-readable multi-line string of all active mock layers. 1454: 1455: =head3 API SPECIFICATION 1456: 1457: =head4 Input 1458: 1459: none 1460: 1461: =head4 Output 1462: 1463: returns: Str 1464: 1465: =cut 1466: 1467: sub diagnose_mocks_pretty { ●1468 → 1471 → 1483 1468: my $diag = diagnose_mocks(); 1469: my @out; 1470: 1471: for my $full_method (sort keys %$diag) { 1472: my $entry = $diag->{$full_method}; 1473: push @out, "$full_method:"; 1474: push @out, " depth: $entry->{depth}"; 1475: push @out, " original_existed: $entry->{original_existed}"; 1476: for my $layer (@{ $entry->{layers} }) { 1477: push @out, sprintf " - type: %-14s installed_at: %s", 1478: $layer->{type}, $layer->{installed_at}; 1479: } 1480: push @out, ''; 1481: } 1482: 1483: return join "\n", @out;
Mutants (Total: 2, Killed: 2, Survived: 0)
1484: } 1485: 1486: # _drain_and_restore -- Private helper 1487: # 1488: # Purpose: Pop all layers from the mock stack for a single target and 1489: # restore the bottom-most saved coderef to the symbol table. 1490: # Does NOT clean up %mocked or %mock_meta -- callers must do 1491: # that themselves. 1492: # Entry: $_[0] -- Str, fully-qualified method name 1493: # Exit: undef 1494: # Side effects: Modifies the symbol table for the target. 1495: sub _drain_and_restore { ●1496 → 1499 → 1506 1496: my $full_method = $_[0]; 1497: 1498: my $final_prev; 1499: while (@{ $mocked{$full_method} }) { 1500: $final_prev = pop @{ $mocked{$full_method} }; 1501: } 1502: 1503: # Restore the original (bottom of stack) to the SAME GV that compiled 1504: # calls hold. We never delete the GV because compiled direct-call ops 1505: # cache the GV at compile time; a new GV would be invisible to them. ●1506 → 1506 → 1521 1506: if (defined $final_prev) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1507: no warnings 'redefine'; 1508: no strict 'refs'; ## no critic (ProhibitNoStrict) 1509: *{$full_method} = $final_prev; 1510: } elsif ($full_method =~ /^CORE::GLOBAL::/) { 1511: # No prior CORE::GLOBAL override existed (mock_core pushed undef). 1512: # Delete the stash entry entirely so Perl's builtin lookup falls back 1513: # to the real CORE function. Reinstating the undef-stub CV is not 1514: # sufficient: Perl treats any non-NULL CV in CORE::GLOBAL as an active 1515: # user override, so the real builtin would never be reached. 1516: my ($bname) = ($full_method =~ /::([^:]+)$/); 1517: no strict 'refs'; ## no critic (ProhibitNoStrict) 1518: delete $CORE::GLOBAL::{$bname}; 1519: } 1520: 1521: return; 1522: } 1523: 1524: # _parse_target -- Private helper 1525: # 1526: # Purpose: Normalise both shorthand ('Pkg::method') and longhand 1527: # ('Pkg', 'method') call forms into a ($package, $method) pair. 1528: # Entry: @_ -- one arg for shorthand, two args for longhand 1529: # Exit: ($package, $method) -- list of two strings 1530: sub _parse_target { ●1531 → 1534 → 1538 1531: my ($arg1, $arg2) = @_; 1532: 1533: # Shorthand: single 'Pkg::method' string -- arg2 is absent (undef) 1534: if (defined $arg1 && !defined $arg2 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1535: return ($1, $2); 1536: } 1537: 1538: return ($arg1, $arg2); 1539: } 1540: 1541: # _caller_info -- Private helper 1542: # 1543: # Purpose: Walk up the call stack to find the first frame outside any 1544: # Test::Mockingbird namespace. Returns a human-readable 1545: # "file line N" string for use in installed_at diagnostics. 1546: # This ensures that sugar functions (mock_return, mock_once, 1547: # etc.) report the user's call site, not their own location. 1548: # Entry: none 1549: # Exit: Str, e.g. "t/my_test.t line 42" 1550: sub _caller_info { ●1551 → 1552 → 1556 1551: my $level = 1; 1552: while (my @info = caller($level)) { 1553: last unless $info[0] =~ /^Test::Mockingbird/; 1554: $level++; 1555: } 1556: my @info = caller($level); 1557: return defined $info[1] ? "$info[1] line $info[2]" : '(unknown)';
Mutants (Total: 2, Killed: 2, Survived: 0)
1558: } 1559: 1560: # _get_prototype -- Private helper 1561: # 1562: # Return the prototype string of a named sub, if any. 1563: # 1564: # Entry: $_[0] -- Str, fully-qualified sub name 1565: # Exit: Str or undef 1566: sub _get_prototype { 1567: my $full = $_[0]; 1568: 1569: # All components (package segments and the sub name itself) must start 1570: # with a letter or underscore -- Perl identifiers cannot begin with a digit. 1571: croak "Invalid fully-qualified name '$full'" 1572: unless $full =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)+$/; 1573: 1574: my ($pkg, $sub) = $full =~ /^(.*)::([^:]+)$/; 1575: my $code = $pkg->can($sub) or return; 1576: return prototype($code);
Mutants (Total: 2, Killed: 2, Survived: 0)
1577: } 1578: 1579: # _is_core_overridable -- Private helper 1580: # 1581: # Determine whether a bare name refers to a CORE builtin that 1582: # Perl allows packages to shadow with a user sub. 1583: # Entry: $_[0] -- Str, simple identifier (no 'CORE::' prefix) 1584: # Exit: Bool -- true if prototype("CORE::$name") succeeds (even if 1585: # the returned prototype is undef, meaning "no prototype") 1586: sub _is_core_overridable { 1587: my $name = $_[0]; 1588: local $@; 1589: eval { my $p = prototype("CORE::$name"); 1 }; 1590: return !$@;
Mutants (Total: 2, Killed: 2, Survived: 0)
1591: } 1592: 1593: =head1 SUPPORT 1594: 1595: This module is provided as-is without any warranty. 1596: 1597: Please report bugs at L<https://github.com/nigelhorne/Test-Mockingbird/issues>. 1598: 1599: =head1 AUTHOR 1600: 1601: Nigel Horne, C<< <njh at nigelhorne.com> >> 1602: 1603: =head1 SEE ALSO 1604: 1605: =over 4 1606: 1607: =item * L<Test Dashboard|https://nigelhorne.github.io/Test-Mockingbird/coverage/> 1608: 1609: =item * L<Test::Mockingbird::Async> 1610: 1611: =item * L<Test::Mockingbird::DeepMock> 1612: 1613: =item * L<Test::Mockingbird::TimeTravel> 1614: 1615: =back 1616: 1617: =head1 REPOSITORY 1618: 1619: L<https://github.com/nigelhorne/Test-Mockingbird> 1620: 1621: =head1 FORMAL SPECIFICATION 1622: 1623: =head2 mock 1624: 1625: mock ≙ 1626: ∀ target : Str; replacement : CodeRef • 1627: pre target ≠'' ∧ defined(replacement) 1628: post mocked'[target] = ⟨saved(target)⟩ ⌢ mocked[target] 1629: ∧ sym_table'[target].CODE = replacement 1630: ∧ prototype(replacement) = prototype(saved(target)) 1631: 1632: =head2 unmock 1633: 1634: unmock ≙ 1635: ∀ target : Str • 1636: let prev = head(mocked[target]) • 1637: post mocked'[target] = tail(mocked[target]) 1638: ∧ sym_table'[target].CODE = prev 1639: ∧ mock_meta'[target] = tail(mock_meta[target]) 1640: 1641: =head2 before 1642: 1643: before ≙ 1644: ∀ target : Str; hook : CodeRef • 1645: pre target ≠'' ∧ ref(hook) = 'CODE' 1646: let orig = sym_table[target].CODE • 1647: post sym_table'[target].CODE = wrapper 1648: ∧ wrapper(@args) ≙ hook(@args); orig(@args) 1649: 1650: =head2 after 1651: 1652: after ≙ 1653: ∀ target : Str; hook : CodeRef • 1654: pre target ≠'' ∧ ref(hook) = 'CODE' 1655: let orig = sym_table[target].CODE • 1656: post sym_table'[target].CODE = wrapper 1657: ∧ wrapper(@args) ≙ let ret = orig(@args) • hook(@args); ret 1658: 1659: =head2 around 1660: 1661: around ≙ 1662: ∀ target : Str; hook : CodeRef • 1663: pre target ≠'' ∧ ref(hook) = 'CODE' 1664: let orig = sym_table[target].CODE • 1665: post sym_table'[target].CODE = wrapper 1666: ∧ wrapper(@args) ≙ hook(orig, @args) 1667: 1668: =head2 mock_core 1669: 1670: mock_core ≙ 1671: ∀ name : Str; replacement : CodeRef • 1672: pre _is_core_overridable(name) ∧ ref(replacement) = 'CODE' 1673: let call_core = eval("sub { CORE::name(@_) }") • 1674: let wrapper = sub { replacement(call_core, @_) } • 1675: post CORE::GLOBAL::name.CODE = wrapper 1676: ∧ prototype(wrapper) = prototype(CORE::name) 1677: ∧ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"] 1678: 1679: =head2 mock_scoped 1680: 1681: mock_scoped ≙ 1682: install all mocks via mock() 1683: ∧ return Guard(full_methods) 1684: ∧ Guard.DESTROY ⇒ ∀ m ∈ full_methods • unmock(m) 1685: 1686: =head2 spy 1687: 1688: spy ≙ 1689: ∀ target : Str • 1690: pre defined(target) 1691: post sym_table'[target].CODE = wrapper(orig) 1692: ∧ wrapper: @args → (calls' = calls ⌢ ⟨[target, @args]⟩ ∧ orig(@args)) 1693: 1694: =head2 inject 1695: 1696: inject ≙ 1697: ∀ pkg : Str; dep : Str; val : Any • 1698: pre pkg ≠'' ∧ dep ≠'' 1699: post sym_table'["${pkg}::${dep}"].CODE = sub { val } 1700: 1701: =head2 inject_all 1702: 1703: inject_all ≙ 1704: ∀ pkg : Str; deps : HashRef • 1705: post ∀ (k,v) ∈ deps • inject(pkg, k, v) 1706: 1707: =head2 intercept_new 1708: 1709: intercept_new ≙ 1710: ∀ class : Str; factory : Any • 1711: pre class ≠'' ∧ @args ≥ 2 1712: let rep = (factory : CodeRef) ? factory : sub { factory } • 1713: post mock("${class}::new", rep) 1714: 1715: =head2 restore_all 1716: 1717: restore_all ≙ 1718: global: mocked' = {} ∧ mock_meta' = {} ∧ call_log' = [] 1719: scoped: ∀ target ∈ dom(mocked) • target =~ /^pkg::/ ⇒ unmock_all(target) 1720: ∧ call_log' = [ e ∈ call_log | e !~ /^pkg::/ ] 1721: 1722: =head2 restore 1723: 1724: restore ≙ 1725: ∀ target : Str • 1726: pre defined(target) 1727: post mocked[target] = [] 1728: 1729: =head2 mock_return 1730: 1731: mock_return ≙ 1732: ∀ target : Str; value : Any • 1733: post sym_table'[target].CODE = sub { value } 1734: 1735: =head2 mock_exception 1736: 1737: mock_exception ≙ 1738: ∀ target : Str; msg : Str • 1739: post sym_table'[target].CODE = sub { croak msg } 1740: 1741: =head2 mock_sequence 1742: 1743: mock_sequence ≙ 1744: ∀ target : Str; values : Seq(Any) • 1745: pre |values| ≥ 1 1746: post let queue = values • 1747: sym_table'[target].CODE = sub { head(queue) if |queue|=1 else shift(queue) } 1748: 1749: =head2 mock_once 1750: 1751: mock_once ≙ 1752: ∀ target : Str; code : CodeRef • 1753: post sym_table'[target] = sub { 1754: result = code(@args) 1755: unmock(target) 1756: return result 1757: } 1758: 1759: =head2 assert_call_order 1760: 1761: assert_call_order ≙ 1762: ∀ expected : Seq(Str) • 1763: pre |expected| ≥ 2 1764: post result = (∀ i • ∃ p_i : ℕ | p_0 < p_1 < … ∧ call_log[p_i] = expected[i]) 1765: 1766: =head2 clear_call_log 1767: 1768: clear_call_log ≙ post call_log' = [] 1769: 1770: =head2 diagnose_mocks 1771: 1772: diagnose_mocks ≙ 1773: returns { target ↦ { depth, layers } | target ∈ dom(mocked) } 1774: 1775: =head2 diagnose_mocks_pretty 1776: 1777: diagnose_mocks_pretty ≙ stringify(diagnose_mocks()) 1778: 1779: =head2 before 1780: 1781: before ≙ 1782: ∀ target : Str; hook : CodeRef • 1783: pre target ≠'' ∧ ref(hook) = 'CODE' 1784: let orig = sym_table[target].CODE • 1785: post sym_table'[target].CODE = wrapper 1786: ∧ wrapper(@args) ≙ hook(@args); orig(@args) 1787: 1788: =head2 after 1789: 1790: after ≙ 1791: ∀ target : Str; hook : CodeRef • 1792: pre target ≠'' ∧ ref(hook) = 'CODE' 1793: let orig = sym_table[target].CODE • 1794: post sym_table'[target].CODE = wrapper 1795: ∧ wrapper(@args) ≙ 1796: let ret = orig(@args) • 1797: hook(@args); 1798: ret 1799: 1800: =head2 around 1801: 1802: around ≙ 1803: ∀ target : Str; hook : CodeRef • 1804: pre target ≠'' ∧ ref(hook) = 'CODE' 1805: let orig = sym_table[target].CODE • 1806: post sym_table'[target].CODE = wrapper 1807: ∧ wrapper(@args) ≙ hook(orig, @args) 1808: 1809: =head2 mock_core 1810: 1811: mock_core ≙ 1812: ∀ name : Str; replacement : CodeRef • 1813: pre _is_core_overridable(name) ∧ ref(replacement) = 'CODE' 1814: let call_core = eval("sub { CORE::name(@_) }") • 1815: let wrapper = sub { replacement(call_core, @_) } • 1816: post CORE::GLOBAL::name.CODE = wrapper 1817: ∧ prototype(wrapper) = prototype(CORE::name) 1818: ∧ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"] 1819: 1820: =head1 LICENCE AND COPYRIGHT 1821: 1822: Copyright 2025-2026 Nigel Horne. 1823: 1824: Usage is subject to the GPL2 licence terms. 1825: If you use it, 1826: please let me know. 1827: 1828: =cut 1829: 1830: 1; 1831: 1832: package Test::Mockingbird::Guard; 1833: 1834: # Guard object returned by mock_scoped. Stores a list of fully-qualified 1835: # method names and calls unmock() on each when destroyed. 1836: 1837: sub new { 1838: my ($class, @full_methods) = @_; 1839: return bless { full_methods => \@full_methods }, $class;
Mutants (Total: 2, Killed: 2, Survived: 0)
1840: } 1841: 1842: sub DESTROY { 1843: my $self = $_[0]; 1844: Test::Mockingbird::unmock($_) for @{ $self->{full_methods} }; 1845: return; 1846: } 1847: 1848: 1;