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.12 78: 79: =cut 80: 81: our $VERSION = '0.12'; 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 → 739 → 741 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: return $orig->(@_);
Mutants (Total: 2, Killed: 2, Survived: 0)
733: }; 734: 735: # Preserve the original's prototype to suppress "Prototype mismatch" 736: # warnings and ensure '_'-prototype functions (stat, lstat, etc.) bind 737: # $_ correctly at the call site when wrapped. 738: my $orig_proto = prototype($orig); 739: if (defined $orig_proto) {
740: &Scalar::Util::set_prototype($wrapper, $orig_proto); 741: } 742: 743: { 744: no warnings 'redefine', 'prototype'; 745: no strict 'refs'; ## no critic (ProhibitNoStrict) 746: *{$full_method} = $wrapper; 747: } 748: 749: push @{ $mock_meta{$full_method} }, { 750: type => _T_SPY, 751: installed_at => _caller_info(), 752: original_existed => $orig_existed, 753: }; 754: 755: return sub { @calls };Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_739_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
756: } 757: 758: =head2 inject 759: 760: Inject a mock dependency into a package. 761: 762: inject('My::Module', 'Dependency', $mock_object); 763: inject 'My::Module::Dependency' => $mock_object; 764: 765: Injecting C<undef> is valid; use argument count (not definedness of the 766: third argument) to distinguish shorthand from longhand. 767: 768: =head3 API SPECIFICATION 769: 770: =head4 Input 771: 772: package -- Str 773: dependency -- Str 774: value -- Any (including undef) 775: 776: =head4 Output 777: 778: returns: undef 779: 780: =head3 MESSAGES 781: 782: "Package and dependency are required for injection" -- missing name 783: 784: =cut 785: 786: sub inject { ●787 → 792 → 798 787: my ($package, $dependency, $mock_object); 788: 789: # Discriminate shorthand (2 args) from longhand (3 args) by argument 790: # count rather than definedness of the third arg so that inject(Pkg, 791: # Dep, undef) -- injecting undef -- is correctly handled. 792: if (@_ == 2 && defined $_[0] && $_[0] =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 2, Killed: 2, Survived: 0)
793: ($package, $dependency, $mock_object) = ($1, $2, $_[1]); 794: } else { 795: ($package, $dependency, $mock_object) = @_; 796: } 797: 798: croak 'Package and dependency are required for injection' 799: unless $package && $dependency; 800: 801: my $full = "${package}::${dependency}"; 802: 803: my ($orig, $orig_existed); 804: { 805: no strict 'refs'; ## no critic (ProhibitNoStrict) 806: $orig_existed = defined(&{$full}) ? 1 : 0; 807: $orig = \&{$full}; 808: } 809: push @{ $mocked{$full} }, $orig; 810: 811: my $wrapper = sub { $mock_object }; 812: 813: { 814: no warnings 'redefine'; 815: no strict 'refs'; ## no critic (ProhibitNoStrict) 816: *{$full} = $wrapper; 817: } 818: 819: # inject() respects $TYPE so that inject_all() or any future wrapper 820: # can label the layer differently (though 'inject' is the sensible default). 821: push @{ $mock_meta{$full} }, { 822: type => $TYPE // _T_INJECT, 823: installed_at => _caller_info(), 824: original_existed => $orig_existed, 825: }; 826: 827: return; 828: } 829: 830: =head2 inject_all 831: 832: Inject multiple dependencies into a package in one call. 833: 834: inject_all('My::Service', { 835: DB => $mock_db, 836: Logger => $mock_logger, 837: }); 838: 839: An empty hashref is a no-op. Each pair is equivalent to a separate 840: C<inject()> call and participates in the same mock stack. 841: 842: =head3 API SPECIFICATION 843: 844: =head4 Input 845: 846: package -- Str 847: dependencies -- HashRef 848: 849: =head4 Output 850: 851: returns: undef 852: 853: =head3 MESSAGES 854: 855: "inject_all requires a package name" -- undef or empty package 856: "inject_all requires a hashref of dependencies" -- second arg not a HashRef 857: 858: =cut 859: 860: sub inject_all { 861: my ($package, $deps) = @_; 862: 863: croak 'inject_all requires a package name' 864: unless defined $package && length $package; 865: 866: croak 'inject_all requires a hashref of dependencies' 867: unless ref $deps eq 'HASH'; 868: 869: inject($package, $_, $deps->{$_}) for keys %$deps; 870: 871: return; 872: } 873: 874: =head2 intercept_new 875: 876: Intercept the C<new> constructor of a class. 877: 878: intercept_new 'My::Service' => $stub_obj; 879: intercept_new 'My::Service' => sub { My::Double->new(@_[1..$#_]) }; 880: 881: When given a plain value (including undef), every call to 882: C<< My::Service->new >> returns that value. When given a coderef, every 883: call invokes the coderef with the original arguments (including the class 884: name as the first argument) and returns its result. 885: 886: This is a thin wrapper around C<mock()>; C<restore_all()>, C<unmock()>, 887: and C<diagnose_mocks()> all work identically. 888: 889: =head3 API SPECIFICATION 890: 891: =head4 Input 892: 893: class -- Str (non-empty) 894: factory -- Any; CodeRef invoked per call, or scalar returned verbatim 895: 896: =head4 Output 897: 898: returns: undef 899: 900: =head3 MESSAGES 901: 902: "intercept_new requires a class name" -- undef/empty class 903: "intercept_new requires a replacement object or coderef" -- factory missing 904: 905: =cut 906: 907: sub intercept_new { 908: my ($class, $factory) = @_; 909: 910: croak 'intercept_new requires a class name' 911: unless defined $class && length $class; 912: croak 'intercept_new requires a replacement object or coderef' 913: if @_ < 2;
Mutants (Total: 3, Killed: 3, Survived: 0)
914: 915: my $replacement = ref($factory) eq 'CODE' 916: ? $factory 917: : sub { $factory }; 918: 919: local $TYPE = _T_INTERCEPT_NEW; 920: mock("${class}::new", $replacement); 921: 922: return; 923: } 924: 925: =head2 mock_core 926: 927: Override a CORE Perl builtin globally via C<CORE::GLOBAL>. 928: 929: # Intercept 'warn' for code compiled after this point 930: mock_core 'warn' => sub { 931: my ($call_warn, @msgs) = @_; 932: push @captured, @msgs; # capture without emitting 933: }; 934: 935: # Call through to the real builtin via $call_builtin 936: mock_core 'stat' => sub { 937: my ($call_stat, $file) = @_; 938: return $call_stat->($file); # delegates to CORE::stat 939: }; 940: 941: unmock 'CORE::GLOBAL::warn'; # peel one layer 942: restore_all(); # drain all layers 943: 944: The replacement receives C<($call_builtin, @original_args)>, mirroring the 945: C<around()> API. C<$call_builtin> is a coderef that calls C<CORE::$name> 946: directly, bypassing any other C<CORE::GLOBAL> override. 947: 948: The override is installed in C<CORE::GLOBAL::$name>, which is Perl's 949: documented mechanism for intercepting named builtins. It affects all 950: packages globally. 951: 952: B<Compile-time semantics:> C<CORE::GLOBAL> overrides are visible to code 953: compiled I<after> the override is installed. To intercept calls in a module 954: under test, install the mock I<before> loading that module (a C<BEGIN> block 955: works). Already-compiled call sites (including direct calls in the current 956: test file) are not affected at runtime. Use string C<eval> when you need 957: code compiled in the same test run to see the override. 958: 959: The wrapper carries the same prototype as C<CORE::$name> so that call-site 960: argument binding (such as the C<_> prototype that reads C<$_> when no 961: argument is given) is preserved. 962: 963: Participates in the same LIFO mock stack as C<mock()>. C<unmock>, 964: C<restore()>, and C<restore_all()> accept C<'CORE::GLOBAL::$name'> as the 965: target. C<diagnose_mocks()> records the layer type as C<'mock_core'>. 966: 967: B<Limitation:> builtins whose prototype begins with C<&> (C<sort>, C<map>, 968: C<grep>) require a literal code block at the call site and cannot be wrapped. 969: 970: =head3 API SPECIFICATION 971: 972: =head4 Input 973: 974: name -- Str, CORE builtin name (no 'CORE::' prefix required) 975: replacement -- CodeRef; receives ($call_builtin, @original_args) 976: 977: =head4 Output 978: 979: returns: undef 980: 981: =head3 MESSAGES 982: 983: "mock_core requires a builtin name and a replacement coderef" -- wrong arg types 984: "mock_core: '$name' is not a valid identifier" -- name has punctuation 985: "mock_core: '$name' is not an overridable Perl builtin" -- unknown builtin 986: "mock_core: cannot build CORE::$name delegator: ..." -- eval failed 987: 988: =cut 989: 990: sub mock_core { 991: my ($name, $replacement) = @_; 992: 993: croak 'mock_core requires a builtin name and a replacement coderef' 994: unless defined $name && ref($replacement) eq 'CODE'; 995: 996: $name =~ s/^CORE:://; # tolerate an optional 'CORE::' prefix 997: 998: croak "mock_core: '$name' is not a valid identifier" 999: unless $name =~ /^\w+$/; 1000: croak "mock_core: '$name' is not an overridable Perl builtin" 1001: unless _is_core_overridable($name); 1002: 1003: my $core_proto = eval { my $p = prototype("CORE::$name"); $p }; 1004: 1005: # Build a delegator that calls CORE::$name directly. Must be eval'd 1006: # because CORE:: names are compile-time constructs -- no runtime coderef 1007: # exists. Calling CORE:: directly bypasses any other CORE::GLOBAL override. 1008: # For '_' prototype (e.g. stat), pass $_[0] explicitly to avoid the 1009: # "Array passed to stat will be coerced to a scalar" compiler warning that 1010: # fires when @_ is passed to a single-arg builtin. 1011: my $args = (defined $core_proto && $core_proto eq '_') ? '$_[0]' : '@_'; 1012: my $call_core = eval "sub { no warnings 'syntax'; CORE::$name($args) }"; ## no critic (ProhibitStringyEval) 1013: croak "mock_core: cannot build CORE::$name delegator: $@" if $@; 1014: 1015: # Wrap in an around-style closure and stamp the CORE prototype onto it 1016: # so call-site argument binding (e.g. '_' reads $_ when arg omitted) works. 1017: # List-op builtins (warn, die, print ...) have no traditional prototype 1018: # string (prototype("CORE::warn") returns undef), but Perl's CORE::GLOBAL 1019: # mechanism expects the override to carry '@'. Use '@' as the fallback so 1020: # the wrapper's prototype matches and suppresses "Prototype mismatch" at 1021: # eval-compile time. 1022: my $wrapper = sub { $replacement->($call_core, @_) }; 1023: my $effective_proto = defined($core_proto) ? $core_proto : '@'; 1024: &Scalar::Util::set_prototype($wrapper, $effective_proto); 1025: 1026: # Install in CORE::GLOBAL -- Perl's documented mechanism for global 1027: # builtin overrides. Track under the full name so unmock/restore_all work. 1028: my $full = "CORE::GLOBAL::$name"; 1029: 1030: my ($orig, $orig_existed); 1031: { 1032: no strict 'refs'; ## no critic (ProhibitNoStrict) 1033: $orig_existed = defined(&{$full}) ? 1 : 0; 1034: # When no prior override existed, push undef rather than \&{$full}. 1035: # \&{$full} auto-vivifies the stash entry and returns an undef-stub CV. 1036: # Reinstating that stub on restore would leave a CORE::GLOBAL entry 1037: # whose non-NULL CV pointer makes Perl treat it as an active override, 1038: # preventing fallback to the real builtin. _drain_and_restore detects 1039: # undef and deletes the stash entry instead. 1040: $orig = $orig_existed ? \&{$full} : undef; 1041: } 1042: push @{ $mocked{$full} }, $orig; 1043: 1044: { 1045: no warnings 'redefine', 'prototype'; 1046: no strict 'refs'; ## no critic (ProhibitNoStrict) 1047: *{$full} = $wrapper; 1048: } 1049: 1050: push @{ $mock_meta{$full} }, { 1051: type => $TYPE // _T_MOCK_CORE, 1052: installed_at => _caller_info(), 1053: original_existed => $orig_existed, 1054: }; 1055: 1056: return; 1057: } 1058: 1059: =head2 restore_all 1060: 1061: Restore all mocked methods and injected dependencies. 1062: 1063: restore_all(); # restore everything 1064: restore_all 'My::Module'; # restore only My::Module's mocks 1065: 1066: When called with a package name, only mocks whose fully-qualified names 1067: begin with that package are restored. The call-order log is pruned to 1068: remove entries for the restored package. 1069: 1070: =head3 API SPECIFICATION 1071: 1072: =head4 Input 1073: 1074: package -- Str, optional 1075: 1076: =head4 Output 1077: 1078: returns: undef 1079: 1080: =cut 1081: 1082: sub restore_all { ●1083 → 1085 → 1104 1083: my $arg = $_[0]; 1084: 1085: if (defined $arg) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1086: my $package = $arg; 1087: 1088: for my $full_method (keys %mocked) { 1089: next unless $full_method =~ /^\Q$package\E::/; 1090: _drain_and_restore($full_method); 1091: # _drain_and_restore explicitly skips hash cleanup; do it here 1092: # to match the behaviour of the global form (%mocked = (); etc.). 1093: delete $mocked{$full_method}; 1094: delete $mock_meta{$full_method}; 1095: } 1096: 1097: # Remove call_log entries for the restored package 1098: @call_log = grep { $_ !~ /^\Q$package\E::/ } @call_log; 1099: 1100: return; 1101: } 1102: 1103: # Global restore: revert every tracked method to its saved state 1104: _drain_and_restore($_) for keys %mocked; 1105: 1106: %mocked = (); 1107: %mock_meta = (); 1108: @call_log = (); 1109: 1110: return; 1111: } 1112: 1113: =head2 restore 1114: 1115: Restore all mock layers for a single method target. 1116: 1117: restore 'My::Module::method'; 1118: 1119: If the method was never mocked this is a no-op. 1120: 1121: =head3 API SPECIFICATION 1122: 1123: =head4 Input 1124: 1125: target -- Str 1126: 1127: =head4 Output 1128: 1129: returns: undef 1130: 1131: =head3 MESSAGES 1132: 1133: "restore requires a target" -- undef target 1134: 1135: =cut 1136: 1137: sub restore { 1138: my $target = $_[0]; 1139: 1140: croak 'restore requires a target' unless defined $target; 1141: 1142: my ($package, $method) = _parse_target($target); 1143: my $full_method = "${package}::${method}"; 1144: 1145: return unless exists $mocked{$full_method}; 1146: 1147: _drain_and_restore($full_method); 1148: delete $mocked{$full_method}; 1149: delete $mock_meta{$full_method}; 1150: 1151: return; 1152: } 1153: 1154: =head2 mock_return 1155: 1156: Mock a method to always return a fixed value. 1157: 1158: mock_return 'My::Module::method' => 42; 1159: 1160: =head3 API SPECIFICATION 1161: 1162: =head4 Input 1163: 1164: target -- Str 1165: value -- Any 1166: 1167: =head4 Output 1168: 1169: returns: undef 1170: 1171: =head3 MESSAGES 1172: 1173: "mock_return requires a target and a value" -- target undefined 1174: 1175: =cut 1176: 1177: sub mock_return { 1178: my ($target, $value) = @_; 1179: 1180: croak 'mock_return requires a target and a value' unless defined $target; 1181: 1182: local $TYPE = _T_MOCK_RETURN; 1183: mock $target => sub { $value }; 1184: 1185: return; 1186: } 1187: 1188: =head2 mock_exception 1189: 1190: Mock a method to always throw an exception. 1191: 1192: mock_exception 'My::Module::method' => 'something went wrong'; 1193: 1194: =head3 API SPECIFICATION 1195: 1196: =head4 Input 1197: 1198: target -- Str 1199: message -- Str 1200: 1201: =head4 Output 1202: 1203: returns: undef 1204: 1205: =head3 MESSAGES 1206: 1207: "mock_exception requires a target and an exception message" -- either missing 1208: 1209: =cut 1210: 1211: sub mock_exception { 1212: my ($target, $message) = @_; 1213: 1214: croak 'mock_exception requires a target and an exception message' 1215: unless defined $target && defined $message; 1216: 1217: local $TYPE = _T_MOCK_EXCEPT; 1218: mock $target => sub { croak $message }; 1219: 1220: return; 1221: } 1222: 1223: =head2 mock_sequence 1224: 1225: Mock a method to return a sequence of values over successive calls. 1226: The last value repeats when the sequence is exhausted. 1227: 1228: mock_sequence 'My::Module::method' => (1, 2, 3); 1229: 1230: =head3 API SPECIFICATION 1231: 1232: =head4 Input 1233: 1234: target -- Str 1235: values -- Array (one or more) 1236: 1237: =head4 Output 1238: 1239: returns: undef 1240: 1241: =head3 MESSAGES 1242: 1243: "mock_sequence requires a target and at least one value" -- empty value list 1244: 1245: =cut 1246: 1247: sub mock_sequence { 1248: my ($target, @values) = @_; 1249: 1250: croak 'mock_sequence requires a target and at least one value' 1251: unless defined $target && @values; 1252: 1253: my @queue = @values; 1254: 1255: local $TYPE = _T_MOCK_SEQ; 1256: mock $target => sub { 1257: return $queue[0] if @queue == 1;
Mutants (Total: 3, Killed: 3, Survived: 0)
1258: return shift @queue;
Mutants (Total: 2, Killed: 2, Survived: 0)
1259: }; 1260: 1261: return; 1262: } 1263: 1264: =head2 mock_once 1265: 1266: Install a mock that fires exactly once. After the first call the previous 1267: implementation is automatically restored. 1268: 1269: mock_once 'My::Module::method' => sub { 'temporary' }; 1270: 1271: =head3 API SPECIFICATION 1272: 1273: =head4 Input 1274: 1275: target -- Str 1276: code -- CodeRef 1277: 1278: =head4 Output 1279: 1280: returns: undef 1281: 1282: =head3 MESSAGES 1283: 1284: "mock_once requires a target and a coderef" -- missing or non-CODE factory 1285: 1286: =head3 PSEUDOCODE 1287: 1288: parse target → (package, method) 1289: wrapper = sub { 1290: result = code(@_) 1291: unmock(package, method) -- pop this very layer 1292: return result 1293: } 1294: install wrapper via mock() with TYPE='mock_once' 1295: 1296: =cut 1297: 1298: sub mock_once { 1299: my ($target, $code) = @_; 1300: 1301: croak 'mock_once requires a target and a coderef' 1302: unless defined $target && ref($code) eq 'CODE'; 1303: 1304: my ($package, $method) = _parse_target($target); 1305: 1306: my $wrapper = sub { 1307: my @result = $code->(@_); 1308: Test::Mockingbird::unmock($package, $method); 1309: return wantarray ? @result : $result[0];
Mutants (Total: 2, Killed: 2, Survived: 0)
1310: }; 1311: 1312: local $TYPE = _T_MOCK_ONCE; 1313: mock $target => $wrapper; 1314: 1315: return; 1316: } 1317: 1318: =head2 assert_call_order 1319: 1320: Assert that the named methods were called in left-to-right order. 1321: 1322: assert_call_order('A::fetch', 'B::process', 'C::save'); 1323: 1324: Produces one TAP ok/not-ok line and returns a boolean. Intervening calls 1325: to other methods are ignored. 1326: 1327: =head3 API SPECIFICATION 1328: 1329: =head4 Input 1330: 1331: methods -- Array of Str (two or more fully-qualified names) 1332: 1333: =head4 Output 1334: 1335: returns: Bool 1336: 1337: =head3 MESSAGES 1338: 1339: "assert_call_order requires at least two method names" -- fewer than two given 1340: 1341: =cut 1342: 1343: sub assert_call_order { ●1344 → 1350 → 1357 1344: my @expected = @_; 1345: 1346: croak 'assert_call_order requires at least two method names' 1347: unless @expected >= 2;
Mutants (Total: 3, Killed: 3, Survived: 0)
1348: 1349: my $pos = 0; 1350: for my $logged (@call_log) { 1351: if ($logged eq $expected[$pos]) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1352: $pos++; 1353: last if $pos == @expected;
Mutants (Total: 1, Killed: 1, Survived: 0)
1354: } 1355: } 1356: ●1357 → 1360 → 1369 1357: my $ok = ($pos == @expected);
Mutants (Total: 1, Killed: 1, Survived: 0)
1358: 1359: require Test::More; 1360: if ($ok) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1361: Test::More::pass("call order: " . join(' -> ', @expected)); 1362: } else { 1363: Test::More::fail("call order: " . join(' -> ', @expected)); 1364: Test::More::diag( 1365: "Expected '$expected[$pos]' next but it was not in the call log" 1366: ); 1367: } 1368: 1369: return $ok;
Mutants (Total: 2, Killed: 2, Survived: 0)
1370: } 1371: 1372: =head2 clear_call_log 1373: 1374: Clear the call-order log without restoring mocks or spies. 1375: 1376: clear_call_log(); 1377: 1378: C<restore_all()> also clears the log automatically. 1379: 1380: =head3 API SPECIFICATION 1381: 1382: =head4 Input 1383: 1384: none 1385: 1386: =head4 Output 1387: 1388: returns: undef 1389: 1390: =cut 1391: 1392: sub clear_call_log { 1393: @call_log = (); 1394: return; 1395: } 1396: 1397: # _record_call -- Private helper 1398: # 1399: # Purpose: Append a fully-qualified method name to the call-order log. 1400: # Used by Test::Mockingbird::Async to participate in 1401: # assert_call_order() without crossing the lexical boundary of 1402: # @call_log. 1403: # Entry: $_[0] -- Str, fully-qualified method name 1404: # Exit: undef 1405: # Side effects: Appends to @call_log 1406: sub _record_call { 1407: push @call_log, $_[0]; 1408: return; 1409: } 1410: 1411: =head2 diagnose_mocks 1412: 1413: Return a structured hashref of all currently active mock layers. 1414: 1415: my $diag = diagnose_mocks(); 1416: # $diag->{'My::Pkg::method'} = { 1417: # depth => 1, 1418: # layers => [ { type => 'mock_return', installed_at => '...' } ], 1419: # } 1420: 1421: =head3 API SPECIFICATION 1422: 1423: =head4 Input 1424: 1425: none 1426: 1427: =head4 Output 1428: 1429: returns: HashRef 1430: 1431: =cut 1432: 1433: sub diagnose_mocks { ●1434 → 1436 → 1447 1434: my %report; 1435: 1436: for my $full_method (sort keys %mocked) { 1437: my $layers = $mock_meta{$full_method} // []; 1438: $report{$full_method} = { 1439: depth => scalar @{ $mocked{$full_method} }, 1440: layers => [ @$layers ], 1441: # original_existed reflects whether the method existed before the 1442: # FIRST mock layer was installed (stored in the bottom-most meta entry) 1443: original_existed => (@$layers && $layers->[0]{original_existed}) ? 1 : 0, 1444: }; 1445: } 1446: 1447: return \%report;
Mutants (Total: 2, Killed: 2, Survived: 0)
1448: } 1449: 1450: =head2 diagnose_mocks_pretty 1451: 1452: Return a human-readable multi-line string of all active mock layers. 1453: 1454: =head3 API SPECIFICATION 1455: 1456: =head4 Input 1457: 1458: none 1459: 1460: =head4 Output 1461: 1462: returns: Str 1463: 1464: =cut 1465: 1466: sub diagnose_mocks_pretty { ●1467 → 1470 → 1482 1467: my $diag = diagnose_mocks(); 1468: my @out; 1469: 1470: for my $full_method (sort keys %$diag) { 1471: my $entry = $diag->{$full_method}; 1472: push @out, "$full_method:"; 1473: push @out, " depth: $entry->{depth}"; 1474: push @out, " original_existed: $entry->{original_existed}"; 1475: for my $layer (@{ $entry->{layers} }) { 1476: push @out, sprintf " - type: %-14s installed_at: %s", 1477: $layer->{type}, $layer->{installed_at}; 1478: } 1479: push @out, ''; 1480: } 1481: 1482: return join "\n", @out;
Mutants (Total: 2, Killed: 2, Survived: 0)
1483: } 1484: 1485: # _drain_and_restore -- Private helper 1486: # 1487: # Purpose: Pop all layers from the mock stack for a single target and 1488: # restore the bottom-most saved coderef to the symbol table. 1489: # Does NOT clean up %mocked or %mock_meta -- callers must do 1490: # that themselves. 1491: # Entry: $_[0] -- Str, fully-qualified method name 1492: # Exit: undef 1493: # Side effects: Modifies the symbol table for the target. 1494: sub _drain_and_restore { ●1495 → 1498 → 1505 1495: my $full_method = $_[0]; 1496: 1497: my $final_prev; 1498: while (@{ $mocked{$full_method} }) { 1499: $final_prev = pop @{ $mocked{$full_method} }; 1500: } 1501: 1502: # Restore the original (bottom of stack) to the SAME GV that compiled 1503: # calls hold. We never delete the GV because compiled direct-call ops 1504: # cache the GV at compile time; a new GV would be invisible to them. ●1505 → 1505 → 1520 1505: if (defined $final_prev) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1506: no warnings 'redefine'; 1507: no strict 'refs'; ## no critic (ProhibitNoStrict) 1508: *{$full_method} = $final_prev; 1509: } elsif ($full_method =~ /^CORE::GLOBAL::/) { 1510: # No prior CORE::GLOBAL override existed (mock_core pushed undef). 1511: # Delete the stash entry entirely so Perl's builtin lookup falls back 1512: # to the real CORE function. Reinstating the undef-stub CV is not 1513: # sufficient: Perl treats any non-NULL CV in CORE::GLOBAL as an active 1514: # user override, so the real builtin would never be reached. 1515: my ($bname) = ($full_method =~ /::([^:]+)$/); 1516: no strict 'refs'; ## no critic (ProhibitNoStrict) 1517: delete $CORE::GLOBAL::{$bname}; 1518: } 1519: 1520: return; 1521: } 1522: 1523: # _parse_target -- Private helper 1524: # 1525: # Purpose: Normalise both shorthand ('Pkg::method') and longhand 1526: # ('Pkg', 'method') call forms into a ($package, $method) pair. 1527: # Entry: @_ -- one arg for shorthand, two args for longhand 1528: # Exit: ($package, $method) -- list of two strings 1529: sub _parse_target { ●1530 → 1533 → 1537 1530: my ($arg1, $arg2) = @_; 1531: 1532: # Shorthand: single 'Pkg::method' string -- arg2 is absent (undef) 1533: if (defined $arg1 && !defined $arg2 && $arg1 =~ /^(.*)::([^:]+)$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1534: return ($1, $2); 1535: } 1536: 1537: return ($arg1, $arg2); 1538: } 1539: 1540: # _caller_info -- Private helper 1541: # 1542: # Purpose: Walk up the call stack to find the first frame outside any 1543: # Test::Mockingbird namespace. Returns a human-readable 1544: # "file line N" string for use in installed_at diagnostics. 1545: # This ensures that sugar functions (mock_return, mock_once, 1546: # etc.) report the user's call site, not their own location. 1547: # Entry: none 1548: # Exit: Str, e.g. "t/my_test.t line 42" 1549: sub _caller_info { ●1550 → 1551 → 1555 1550: my $level = 1; 1551: while (my @info = caller($level)) { 1552: last unless $info[0] =~ /^Test::Mockingbird/; 1553: $level++; 1554: } 1555: my @info = caller($level); 1556: return defined $info[1] ? "$info[1] line $info[2]" : '(unknown)';
Mutants (Total: 2, Killed: 2, Survived: 0)
1557: } 1558: 1559: # _get_prototype -- Private helper 1560: # 1561: # Return the prototype string of a named sub, if any. 1562: # 1563: # Entry: $_[0] -- Str, fully-qualified sub name 1564: # Exit: Str or undef 1565: sub _get_prototype { 1566: my $full = $_[0]; 1567: 1568: # All components (package segments and the sub name itself) must start 1569: # with a letter or underscore -- Perl identifiers cannot begin with a digit. 1570: croak "Invalid fully-qualified name '$full'" 1571: unless $full =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)+$/; 1572: 1573: my ($pkg, $sub) = $full =~ /^(.*)::([^:]+)$/; 1574: my $code = $pkg->can($sub) or return; 1575: return prototype($code);
Mutants (Total: 2, Killed: 2, Survived: 0)
1576: } 1577: 1578: # _is_core_overridable -- Private helper 1579: # 1580: # Determine whether a bare name refers to a CORE builtin that 1581: # Perl allows packages to shadow with a user sub. 1582: # Entry: $_[0] -- Str, simple identifier (no 'CORE::' prefix) 1583: # Exit: Bool -- true if prototype("CORE::$name") succeeds (even if 1584: # the returned prototype is undef, meaning "no prototype") 1585: sub _is_core_overridable { 1586: my $name = $_[0]; 1587: local $@; 1588: eval { my $p = prototype("CORE::$name"); 1 }; 1589: return !$@;
Mutants (Total: 2, Killed: 2, Survived: 0)
1590: } 1591: 1592: =head1 SUPPORT 1593: 1594: This module is provided as-is without any warranty. 1595: 1596: Please report bugs at L<https://github.com/nigelhorne/Test-Mockingbird/issues>. 1597: 1598: =head1 AUTHOR 1599: 1600: Nigel Horne, C<< <njh at nigelhorne.com> >> 1601: 1602: =head1 SEE ALSO 1603: 1604: =over 4 1605: 1606: =item * L<Test Dashboard|https://nigelhorne.github.io/Test-Mockingbird/coverage/> 1607: 1608: =item * L<Test::Mockingbird::Async> 1609: 1610: =item * L<Test::Mockingbird::DeepMock> 1611: 1612: =item * L<Test::Mockingbird::TimeTravel> 1613: 1614: =back 1615: 1616: =head1 REPOSITORY 1617: 1618: L<https://github.com/nigelhorne/Test-Mockingbird> 1619: 1620: =head1 FORMAL SPECIFICATION 1621: 1622: =head2 mock 1623: 1624: mock ≙ 1625: ∀ target : Str; replacement : CodeRef • 1626: pre target ≠'' ∧ defined(replacement) 1627: post mocked'[target] = ⟨saved(target)⟩ ⌢ mocked[target] 1628: ∧ sym_table'[target].CODE = replacement 1629: ∧ prototype(replacement) = prototype(saved(target)) 1630: 1631: =head2 unmock 1632: 1633: unmock ≙ 1634: ∀ target : Str • 1635: let prev = head(mocked[target]) • 1636: post mocked'[target] = tail(mocked[target]) 1637: ∧ sym_table'[target].CODE = prev 1638: ∧ mock_meta'[target] = tail(mock_meta[target]) 1639: 1640: =head2 before 1641: 1642: before ≙ 1643: ∀ target : Str; hook : CodeRef • 1644: pre target ≠'' ∧ ref(hook) = 'CODE' 1645: let orig = sym_table[target].CODE • 1646: post sym_table'[target].CODE = wrapper 1647: ∧ wrapper(@args) ≙ hook(@args); orig(@args) 1648: 1649: =head2 after 1650: 1651: after ≙ 1652: ∀ target : Str; hook : CodeRef • 1653: pre target ≠'' ∧ ref(hook) = 'CODE' 1654: let orig = sym_table[target].CODE • 1655: post sym_table'[target].CODE = wrapper 1656: ∧ wrapper(@args) ≙ let ret = orig(@args) • hook(@args); ret 1657: 1658: =head2 around 1659: 1660: around ≙ 1661: ∀ target : Str; hook : CodeRef • 1662: pre target ≠'' ∧ ref(hook) = 'CODE' 1663: let orig = sym_table[target].CODE • 1664: post sym_table'[target].CODE = wrapper 1665: ∧ wrapper(@args) ≙ hook(orig, @args) 1666: 1667: =head2 mock_core 1668: 1669: mock_core ≙ 1670: ∀ name : Str; replacement : CodeRef • 1671: pre _is_core_overridable(name) ∧ ref(replacement) = 'CODE' 1672: let call_core = eval("sub { CORE::name(@_) }") • 1673: let wrapper = sub { replacement(call_core, @_) } • 1674: post CORE::GLOBAL::name.CODE = wrapper 1675: ∧ prototype(wrapper) = prototype(CORE::name) 1676: ∧ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"] 1677: 1678: =head2 mock_scoped 1679: 1680: mock_scoped ≙ 1681: install all mocks via mock() 1682: ∧ return Guard(full_methods) 1683: ∧ Guard.DESTROY ⇒ ∀ m ∈ full_methods • unmock(m) 1684: 1685: =head2 spy 1686: 1687: spy ≙ 1688: ∀ target : Str • 1689: pre defined(target) 1690: post sym_table'[target].CODE = wrapper(orig) 1691: ∧ wrapper: @args → (calls' = calls ⌢ ⟨[target, @args]⟩ ∧ orig(@args)) 1692: 1693: =head2 inject 1694: 1695: inject ≙ 1696: ∀ pkg : Str; dep : Str; val : Any • 1697: pre pkg ≠'' ∧ dep ≠'' 1698: post sym_table'["${pkg}::${dep}"].CODE = sub { val } 1699: 1700: =head2 inject_all 1701: 1702: inject_all ≙ 1703: ∀ pkg : Str; deps : HashRef • 1704: post ∀ (k,v) ∈ deps • inject(pkg, k, v) 1705: 1706: =head2 intercept_new 1707: 1708: intercept_new ≙ 1709: ∀ class : Str; factory : Any • 1710: pre class ≠'' ∧ @args ≥ 2 1711: let rep = (factory : CodeRef) ? factory : sub { factory } • 1712: post mock("${class}::new", rep) 1713: 1714: =head2 restore_all 1715: 1716: restore_all ≙ 1717: global: mocked' = {} ∧ mock_meta' = {} ∧ call_log' = [] 1718: scoped: ∀ target ∈ dom(mocked) • target =~ /^pkg::/ ⇒ unmock_all(target) 1719: ∧ call_log' = [ e ∈ call_log | e !~ /^pkg::/ ] 1720: 1721: =head2 restore 1722: 1723: restore ≙ 1724: ∀ target : Str • 1725: pre defined(target) 1726: post mocked[target] = [] 1727: 1728: =head2 mock_return 1729: 1730: mock_return ≙ 1731: ∀ target : Str; value : Any • 1732: post sym_table'[target].CODE = sub { value } 1733: 1734: =head2 mock_exception 1735: 1736: mock_exception ≙ 1737: ∀ target : Str; msg : Str • 1738: post sym_table'[target].CODE = sub { croak msg } 1739: 1740: =head2 mock_sequence 1741: 1742: mock_sequence ≙ 1743: ∀ target : Str; values : Seq(Any) • 1744: pre |values| ≥ 1 1745: post let queue = values • 1746: sym_table'[target].CODE = sub { head(queue) if |queue|=1 else shift(queue) } 1747: 1748: =head2 mock_once 1749: 1750: mock_once ≙ 1751: ∀ target : Str; code : CodeRef • 1752: post sym_table'[target] = sub { 1753: result = code(@args) 1754: unmock(target) 1755: return result 1756: } 1757: 1758: =head2 assert_call_order 1759: 1760: assert_call_order ≙ 1761: ∀ expected : Seq(Str) • 1762: pre |expected| ≥ 2 1763: post result = (∀ i • ∃ p_i : ℕ | p_0 < p_1 < … ∧ call_log[p_i] = expected[i]) 1764: 1765: =head2 clear_call_log 1766: 1767: clear_call_log ≙ post call_log' = [] 1768: 1769: =head2 diagnose_mocks 1770: 1771: diagnose_mocks ≙ 1772: returns { target ↦ { depth, layers } | target ∈ dom(mocked) } 1773: 1774: =head2 diagnose_mocks_pretty 1775: 1776: diagnose_mocks_pretty ≙ stringify(diagnose_mocks()) 1777: 1778: =head2 before 1779: 1780: before ≙ 1781: ∀ target : Str; hook : CodeRef • 1782: pre target ≠'' ∧ ref(hook) = 'CODE' 1783: let orig = sym_table[target].CODE • 1784: post sym_table'[target].CODE = wrapper 1785: ∧ wrapper(@args) ≙ hook(@args); orig(@args) 1786: 1787: =head2 after 1788: 1789: after ≙ 1790: ∀ target : Str; hook : CodeRef • 1791: pre target ≠'' ∧ ref(hook) = 'CODE' 1792: let orig = sym_table[target].CODE • 1793: post sym_table'[target].CODE = wrapper 1794: ∧ wrapper(@args) ≙ 1795: let ret = orig(@args) • 1796: hook(@args); 1797: ret 1798: 1799: =head2 around 1800: 1801: around ≙ 1802: ∀ target : Str; hook : CodeRef • 1803: pre target ≠'' ∧ ref(hook) = 'CODE' 1804: let orig = sym_table[target].CODE • 1805: post sym_table'[target].CODE = wrapper 1806: ∧ wrapper(@args) ≙ hook(orig, @args) 1807: 1808: =head2 mock_core 1809: 1810: mock_core ≙ 1811: ∀ name : Str; replacement : CodeRef • 1812: pre _is_core_overridable(name) ∧ ref(replacement) = 'CODE' 1813: let call_core = eval("sub { CORE::name(@_) }") • 1814: let wrapper = sub { replacement(call_core, @_) } • 1815: post CORE::GLOBAL::name.CODE = wrapper 1816: ∧ prototype(wrapper) = prototype(CORE::name) 1817: ∧ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"] 1818: 1819: =head1 LICENCE AND COPYRIGHT 1820: 1821: Copyright 2025-2026 Nigel Horne. 1822: 1823: Usage is subject to the GPL2 licence terms. 1824: If you use it, 1825: please let me know. 1826: 1827: =cut 1828: 1829: 1; 1830: 1831: package Test::Mockingbird::Guard; 1832: 1833: # Guard object returned by mock_scoped. Stores a list of fully-qualified 1834: # method names and calls unmock() on each when destroyed. 1835: 1836: sub new { 1837: my ($class, @full_methods) = @_; 1838: return bless { full_methods => \@full_methods }, $class;
Mutants (Total: 2, Killed: 2, Survived: 0)
1839: } 1840: 1841: sub DESTROY { 1842: my $self = $_[0]; 1843: Test::Mockingbird::unmock($_) for @{ $self->{full_methods} }; 1844: return; 1845: } 1846: 1847: 1;