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