File Coverage

File:blib/lib/Test/Mockingbird.pm
Coverage:97.7%

linestmtbrancondsubtimecode
1package Test::Mockingbird;
2
3
23
23
23
1538898
17
298
use strict;
4
23
23
23
33
14
461
use warnings;
5
23
23
190
39
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
23
23
23
30
26
516
use Carp       qw(croak carp);
14
23
23
23
41
16
263
use Exporter   'import';
15
23
23
23
56
12
485
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.
19use constant {
20
23
3737
        _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
23
23
31
16
};
34
35our @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.
62our $TYPE;
63
64# Internal mocking state -- module-level lexicals.
65my %mocked;    # full_method => [ stack of coderefs (or undef stubs) ]
66my %mock_meta; # full_method => [ { type => ..., installed_at => ... }, ... ]
67my @call_log;  # ordered log of every spied call
68
69 - 79
=head1 NAME

Test::Mockingbird - Advanced mocking library for Perl with support for
dependency injection, spies, call ordering, constructor interception, and
async Future mocking

=head1 VERSION

Version 0.12

=cut
80
81our $VERSION = '0.12';
82
83 - 237
=head1 SYNOPSIS

  use Test::Mockingbird;

  # Mocking (shorthand form)
  mock 'My::Module::method' => sub { 'mocked' };

  # Mocking (longhand form)
  mock('My::Module', 'method', sub { 'mocked' });

  # Spying
  my $spy = spy 'My::Module::method';
  My::Module::method('arg1');
  my @calls = $spy->();   # ( ['My::Module::method', 'arg1'], ... )

  # Dependency injection
  inject 'My::Module::Dependency' => $mock_object;

  # Batch dependency injection
  inject_all('My::Module', {
      DB     => $mock_db,
      Logger => $mock_logger,
  });

  # Constructor interception
  intercept_new 'My::Service' => $stub_obj;
  intercept_new 'My::Service' => sub { My::Double->new(@_[1..$#_]) };

  # Unmock one layer
  unmock 'My::Module::method';

  # Restore everything
  restore_all();

  # Call ordering
  spy 'A::fetch';
  spy 'B::process';
  A::fetch();
  B::process();
  assert_call_order('A::fetch', 'B::process');
  clear_call_log();

=head1 DESCRIPTION

Test::Mockingbird provides mocking, spying, dependency injection,
call-order verification, and constructor interception for Perl test suites.

=head1 DIAGNOSTICS

=head2 diagnose_mocks

Returns a structured hashref of all active mock layers.

=head2 diagnose_mocks_pretty

Returns a human-readable multi-line string of all active mock layers.

=head2 Diagnostic Metadata

Each installed layer records:

  type          -- category (mock, spy, inject, mock_return, ...)
  installed_at  -- file and line number of the outermost user call site

=head1 LIMITATIONS

=over 4

=item C<< ->can() >> may return truthy after unmocking a never-existed method

Perl's typeglob (GV) system auto-vivifies a GV entry the first time
C<\&{$full_method}> is called internally (in C<mock()>, C<spy()>, or
C<inject()>). After unmocking, this GV entry remains in the stash with an
"undefined sub" placeholder in the CODE slot. C<< Package->can('method') >>
tests the GV's existence in the stash, not whether the CODE slot is defined,
so it may still return a truthy value.

To test whether a sub is callable, use C<defined(&Package::method)> rather
than C<< Package->can('method') >>. C<defined(&...)> correctly returns false
for the placeholder stub. Calling the stub dies with C<"Undefined subroutine">.

Deleting the GV from the stash (via C<delete $stash{method}>) would make
C<< ->can() >> return false but would break subsequent mock/inject stacking:
compiled direct calls (C<Package::method()>) cache the GV at compile time,
so a new GV installed after a delete is invisible to those compiled calls.

=item Prototype mismatch warning from C<spy()>

C<spy()> installs its wrapper directly without going through C<mock()>,
so C<Scalar::Util::set_prototype> is not applied. Wrapping a prototyped
function with C<spy()> still emits a C<Prototype mismatch> warning. Use
C<mock()> with a delegating wrapper if warning-free wrapping is required.

=item No nested deep_mock scopes

L<Test::Mockingbird::DeepMock> calls C<restore_all()> at scope exit, which
removes every active mock. Nested C<deep_mock> blocks cause the inner exit
to also tear down the outer mocks. Do not nest C<deep_mock> calls.

=item Thread safety

The internal state (C<%mocked>, C<%mock_meta>, C<@call_log>) is per-process
lexical state. Concurrent threads that install and restore mocks will race.
Do not use this module in threaded test harnesses without external locking.

=item Spy return value is a flat list

C<spy()> and C<async_spy()> return a coderef that yields a flat list of
call records. A future version may return an arrayref to reduce stack
pressure; the API is not yet changed to avoid breaking callers.

=item Private-function encapsulation

Functions prefixed with C<_> are private by convention but are not enforced
at runtime (C<Sub::Private> is not activated). White-box tests in C<t/unit.t>
call private functions directly. If C<Sub::Private> enforcement is added, a
testing-interface export mechanism will be required.

=back

=encoding utf-8

=head1 METHODS

=head2 mock

Replace a method with a coderef.

    mock('My::Module', 'method', sub { 'mocked' });
    mock 'My::Module::method' => sub { 'mocked' };

Mocks stack in LIFO order. Each C<mock()> call saves the current CODE slot
(or the auto-vivified undef stub if the method does not exist) and installs
the replacement. C<unmock()> pops one layer; C<restore_all()> drains all.

If the original carries a Perl prototype, the same prototype is stamped onto
the replacement coderef before installation, suppressing C<Prototype mismatch>
warnings.

=head3 API SPECIFICATION

=head4 Input

    target      -- Str, 'Pkg::method' or ('Pkg', 'method')
    replacement -- CodeRef

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package, method and replacement are required" -- target or coderef missing

=cut
238
239sub mock {
240
412
519869
        my ($arg1, $arg2, $arg3) = @_;
241
242
412
233
        my ($package, $method, $replacement);
243
244        # Shorthand: 'Pkg::method' => $code (arg3 absent)
245
412
1069
        if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
246
242
303
                ($package, $method, $replacement) = ($1, $2, $arg2);
247        } else {
248
170
140
                ($package, $method, $replacement) = ($arg1, $arg2, $arg3);
249        }
250
251
412
819
        croak 'Package, method and replacement are required for mocking'
252                unless $package && $method && $replacement;
253
254
395
257
        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
395
242
        my ($original, $orig_existed);
261        {
262
23
23
23
395
63
24
1163
216
                no strict 'refs';    ## no critic (ProhibitNoStrict)
263
395
395
234
615
                $orig_existed = defined(&{$full_method}) ? 1 : 0;
264
395
395
243
364
                $original     = \&{$full_method};
265        }
266
395
395
242
388
        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
395
270
        my $orig_proto = prototype($original);
271
395
329
        if (defined $orig_proto) {
272
16
40
                &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
23
23
23
395
35
19
374
211
                no warnings 'redefine', 'prototype';
283
23
23
23
31
14
2541
                no strict 'refs';    ## no critic (ProhibitNoStrict)
284
395
395
222
501
                *{$full_method} = $replacement;
285        }
286
287
395
395
226
641
        push @{ $mock_meta{$full_method} }, {
288                type             => $TYPE // _T_MOCK,
289                installed_at     => _caller_info(),
290                original_existed => $orig_existed,
291        };
292
293
395
389
        return;
294}
295
296 - 322
=head2 unmock

Restore the previous implementation of a mocked method (one layer).

    unmock('My::Module', 'method');
    unmock 'My::Module::method';

If the method did not exist before it was mocked, the original undef-stub
is restored so that calling the method dies with C<"Undefined subroutine">.
Note: C<< ->can() >> may still return truthy; use C<defined(&...)> to test
whether a method is callable. See L</LIMITATIONS>.

=head3 API SPECIFICATION

=head4 Input

    target -- Str, 'Pkg::method' or ('Pkg', 'method')

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package and method are required for unmocking" -- target missing

=cut
323
324sub unmock {
325
106
17616
        my ($arg1, $arg2) = @_;
326
327
106
73
        my ($package, $method);
328
106
380
        if (defined $arg1 && !defined $arg2 && $arg1 =~ /^(.*)::([^:]+)$/) {
329
79
109
                ($package, $method) = ($1, $2);
330        } else {
331
27
21
                ($package, $method) = ($arg1, $arg2);
332        }
333
334
106
193
        croak 'Package and method are required for unmocking'
335                unless $package && $method;
336
337
100
88
        my $full_method = "${package}::${method}";
338
339        # Nothing to do if this method was never mocked
340
100
95
131
129
        return unless exists $mocked{$full_method} && @{ $mocked{$full_method} };
341
342
95
95
90
84
        my $prev = pop @{ $mocked{$full_method} };
343
344
95
108
        if (defined $prev) {
345
23
23
23
45
10
294
                no warnings 'redefine';
346
23
23
23
32
9
840
                no strict 'refs';    ## no critic (ProhibitNoStrict)
347
94
94
59
207
                *{$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
1
2
                my ($bname) = ($full_method =~ /::([^:]+)$/);
352
23
23
23
37
18
2158
                no strict 'refs';    ## no critic (ProhibitNoStrict)
353
1
2
                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
95
95
71
101
        pop @{ $mock_meta{$full_method} };
360
361        # Clean up empty tracking structures
362
95
95
118
113
        unless (@{ $mocked{$full_method} }) {
363
75
58
                delete $mocked{$full_method};
364
75
68
                delete $mock_meta{$full_method};
365        }
366
367
95
104
        return;
368}
369
370 - 401
=head2 before

Run a hook before a method, then call the original and return its value.

    before 'My::Module::method' => sub { my @args = @_; ... };
    before('My::Module', 'method', sub { ... });

The hook receives the same C<@_> that the original would have received. Its
return value is discarded. The original is always called and its return value
is passed to the caller unchanged. Context (list / scalar / void) is
preserved.

Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer,
C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as
C<'before'>.

=head3 API SPECIFICATION

=head4 Input

    target -- Str, 'Pkg::method' or ('Pkg', 'method')
    hook   -- CodeRef; receives (@original_args), return value discarded

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package, method and hook are required for before()" -- target or hook missing or non-CODE

=cut
402
403sub before {
404
34
110050
        my ($arg1, $arg2, $arg3) = @_;
405
406
34
26
        my ($package, $method, $hook);
407
34
131
        if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
408
29
42
                ($package, $method, $hook) = ($1, $2, $arg2);
409        } else {
410
5
5
                ($package, $method, $hook) = ($arg1, $arg2, $arg3);
411        }
412
413
34
101
        croak 'Package, method and hook are required for before()'
414                unless $package && $method && ref($hook) eq 'CODE';
415
416
29
26
        my $full_method = "${package}::${method}";
417
29
18
        my $orig;
418        {
419
23
23
23
29
39
19
2707
16
                no strict 'refs';    ## no critic (ProhibitNoStrict)
420
29
29
19
51
                $orig = \&{$full_method};
421        }
422
423
29
23
        local $TYPE = _T_BEFORE;
424        mock($package, $method, sub {
425
28
102
                my @args = @_;
426
28
38
                $hook->(@args);
427
27
56
                if (wantarray) {
428
3
4
                        return $orig->(@args);
429                } elsif (defined wantarray) {
430
14
13
                        return scalar $orig->(@args);
431                } else {
432
10
29
                        $orig->(@args);
433
10
13
                        return;
434                }
435
29
58
        });
436
437
29
31
        return;
438}
439
440 - 475
=head2 after

Run a hook after a method and return the original's value.

    after 'My::Module::method' => sub { my @args = @_; ... };
    after('My::Module', 'method', sub { ... });

The original is called first. Its return value is captured, then the hook is
called with the same C<@_> that the original received. The hook's return
value is discarded and the original's return value is passed to the caller
unchanged. Context (list / scalar / void) is preserved.

If the original throws, the exception propagates immediately and the hook is
B<not> called. Use C<around()> if you need to run code unconditionally after
the original.

Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer,
C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as
C<'after'>.

=head3 API SPECIFICATION

=head4 Input

    target -- Str, 'Pkg::method' or ('Pkg', 'method')
    hook   -- CodeRef; receives (@original_args), return value discarded

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package, method and hook are required for after()" -- target or hook missing or non-CODE

=cut
476
477sub after {
478
33
23882
        my ($arg1, $arg2, $arg3) = @_;
479
480
33
23
        my ($package, $method, $hook);
481
33
115
        if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
482
28
38
                ($package, $method, $hook) = ($1, $2, $arg2);
483        } else {
484
5
5
                ($package, $method, $hook) = ($arg1, $arg2, $arg3);
485        }
486
487
33
99
        croak 'Package, method and hook are required for after()'
488                unless $package && $method && ref($hook) eq 'CODE';
489
490
28
24
        my $full_method = "${package}::${method}";
491
28
15
        my $orig;
492        {
493
23
23
23
28
59
29
2867
20
                no strict 'refs';    ## no critic (ProhibitNoStrict)
494
28
28
15
39
                $orig = \&{$full_method};
495        }
496
497
28
26
        local $TYPE = _T_AFTER;
498        mock($package, $method, sub {
499
29
132
                my @args = @_;
500
29
35
                if (wantarray) {
501
3
5
                        my @ret = $orig->(@args);
502
3
9
                        $hook->(@args);
503
3
6
                        return @ret;
504                } elsif (defined wantarray) {
505
16
17
                        my $ret = $orig->(@args);
506
16
33
                        $hook->(@args);
507
15
24
                        return $ret;
508                } else {
509
10
11
                        $orig->(@args);
510
8
17
                        $hook->(@args);
511
8
12
                        return;
512                }
513
28
53
        });
514
515
28
29
        return;
516}
517
518 - 562
=head2 around

Replace a method with a hook that receives the original coderef as its first
argument.

    around 'My::Module::method' => sub {
        my ($orig, @args) = @_;
        my $result = $orig->(@args);   # call original
        return $result * 2;            # modify return value
    };

    around('My::Module', 'method', sub {
        my ($orig, @args) = @_;
        return $orig->(@args);
    });

The hook receives C<($orig_coderef, @original_args)>. It may call C<$orig>
zero or more times with any arguments. Its return value becomes the return
value of the method. The hook is responsible for context handling when that
matters.

C<around()> is the preferred alternative to C<mock()> when you need to call
through to the original: it captures the original and passes it as the first
argument, avoiding the boilerplate of a separate C<\&{...}> capture.

Uses the same LIFO mock stack as C<mock()>: C<unmock()> peels one layer,
C<restore_all()> drains all. C<diagnose_mocks()> records the layer type as
C<'around'>.

=head3 API SPECIFICATION

=head4 Input

    target -- Str, 'Pkg::method' or ('Pkg', 'method')
    hook   -- CodeRef; receives ($orig_coderef, @original_args)

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package, method and hook are required for around()" -- target or hook missing or non-CODE

=cut
563
564sub around {
565
36
23849
        my ($arg1, $arg2, $arg3) = @_;
566
567
36
19
        my ($package, $method, $hook);
568
36
161
        if (defined $arg1 && !defined $arg3 && $arg1 =~ /^(.*)::([^:]+)$/) {
569
31
46
                ($package, $method, $hook) = ($1, $2, $arg2);
570        } else {
571
5
6
                ($package, $method, $hook) = ($arg1, $arg2, $arg3);
572        }
573
574
36
104
        croak 'Package, method and hook are required for around()'
575                unless $package && $method && ref($hook) eq 'CODE';
576
577
31
22
        my $full_method = "${package}::${method}";
578
31
19
        my $orig;
579        {
580
23
23
23
31
36
39
5353
19
                no strict 'refs';    ## no critic (ProhibitNoStrict)
581
31
31
16
42
                $orig = \&{$full_method};
582        }
583
584
31
23
        local $TYPE = _T_AROUND;
585
31
29
58
345
        mock($package, $method, sub { $hook->($orig, @_) });
586
587
31
30
        return;
588}
589
590 - 628
=head2 mock_scoped

Create a scoped mock that restores automatically when the guard goes out of scope.

=head3 Single-method forms

    my $g = mock_scoped 'My::Module::method' => sub { 'mocked' };
    my $g = mock_scoped('My::Module', 'method', sub { ... });

=head3 Multi-method forms

    my $g = mock_scoped('My::Module',
        fetch  => sub { 'mocked_fetch'  },
        save   => sub { 'mocked_save'   },
    );

    my $g = mock_scoped(
        'My::Module::fetch'  => sub { 'mocked_fetch'  },
        'Other::Module::save' => sub { 'mocked_save'  },
    );

All mocked methods are restored when C<$g> goes out of scope.

=head3 API SPECIFICATION

=head4 Input

    args -- four recognised forms (see above)

=head4 Output

    returns: Test::Mockingbird::Guard

=head3 MESSAGES

  "mock_scoped: unrecognised argument form" -- none of the four forms matched
  "mock_scoped: expected coderef for '$target'" -- non-CODE value provided

=cut
629
630sub mock_scoped {
631
38
197748
        my @args = @_;
632
633
38
26
        my @pairs;
634
635
38
200
        if (@args == 2 && ref($args[1]) eq 'CODE') {
636
13
21
                my ($pkg, $meth) = _parse_target($args[0]);
637
13
24
                push @pairs, [ $pkg, $meth, $args[1] ];
638
639        } elsif (@args == 3 && !ref($args[1]) && ref($args[2]) eq 'CODE') {
640
4
9
                push @pairs, [ $args[0], $args[1], $args[2] ];
641
642        } elsif (@args >= 4 && (@args % 2) == 0 && ref($args[1]) eq 'CODE') {
643
5
8
                my @a = @args;
644
5
7
                while (@a) {
645
11
14
                        my ($target, $code) = splice @a, 0, 2;
646
11
20
                        croak "mock_scoped: expected coderef for '$target'"
647                                unless ref($code) eq 'CODE';
648
10
14
                        my ($pkg, $meth) = _parse_target($target);
649
10
18
                        push @pairs, [ $pkg, $meth, $code ];
650                }
651
652        } elsif (@args >= 5 && (@args % 2) == 1 && ref($args[2]) eq 'CODE') {
653
7
27
                my @a   = @args;
654
7
6
                my $pkg = shift @a;
655
7
10
                while (@a) {
656
15
16
                        my ($meth, $code) = splice @a, 0, 2;
657
15
23
                        croak "mock_scoped: expected coderef for method '$meth'"
658                                unless ref($code) eq 'CODE';
659
14
23
                        push @pairs, [ $pkg, $meth, $code ];
660                }
661
662        } else {
663
9
51
                croak 'mock_scoped: unrecognised argument form';
664        }
665
666
27
23
        my @full_methods;
667        {
668
27
27
22
28
                local $TYPE = _T_MOCK_SCOPED;
669
27
26
                for my $pair (@pairs) {
670
39
39
25
41
                        my ($pkg, $meth, $code) = @{$pair};
671
39
68
                        mock($pkg, $meth, $code);
672
39
47
                        push @full_methods, "${pkg}::${meth}";
673                }
674        }
675
676
27
57
        return Test::Mockingbird::Guard->new(@full_methods);
677}
678
679 - 706
=head2 spy

Wrap a method so that every call is recorded. The original method is still
called and its return value is passed back to the caller.

    my $spy = spy 'My::Module::method';
    My::Module::method('arg');
    my @calls = $spy->();   # ( ['My::Module::method', 'arg'], ... )
    restore_all();

Returns a coderef that, when invoked, returns the list of captured call
records. Each record is an arrayref C<[ $full_method, @args ]>.

=head3 API SPECIFICATION

=head4 Input

    target -- Str, 'Pkg::method' or ('Pkg', 'method')

=head4 Output

    returns: CodeRef   # yields list of call records on invocation

=head3 MESSAGES

  "Package and method are required for spying" -- target missing or incomplete

=cut
707
708sub spy {
709
120
207221
        my ($package, $method) = _parse_target(@_);
710
711
120
229
        croak 'Package and method are required for spying'
712                unless $package && $method;
713
714
116
95
        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
116
74
        my ($orig, $orig_existed);
720        {
721
23
23
23
116
50
14
1275
69
                no strict 'refs';    ## no critic (ProhibitNoStrict)
722
116
116
58
216
                $orig_existed = defined(&{$full_method}) ? 1 : 0;
723
116
116
83
104
                $orig         = \&{$full_method};
724        }
725
116
116
85
118
        push @{ $mocked{$full_method} }, $orig;
726
727
116
62
        my @calls;
728
729        my $wrapper = sub {
730
131
1800
                push @calls,    [ $full_method, @_ ];
731
131
90
                push @call_log, $full_method;
732
131
133
                return $orig->(@_);
733
116
156
        };
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
116
104
        my $orig_proto = prototype($orig);
739
116
105
        if (defined $orig_proto) {
740
1
2
                &Scalar::Util::set_prototype($wrapper, $orig_proto);
741        }
742
743        {
744
23
23
23
116
29
14
363
61
                no warnings 'redefine', 'prototype';
745
23
23
23
26
18
2258
                no strict 'refs';    ## no critic (ProhibitNoStrict)
746
116
116
67
144
                *{$full_method} = $wrapper;
747        }
748
749
116
116
83
113
        push @{ $mock_meta{$full_method} }, {
750                type             => _T_SPY,
751                installed_at     => _caller_info(),
752                original_existed => $orig_existed,
753        };
754
755
116
48
179
1824
        return sub { @calls };
756}
757
758 - 784
=head2 inject

Inject a mock dependency into a package.

    inject('My::Module', 'Dependency', $mock_object);
    inject 'My::Module::Dependency' => $mock_object;

Injecting C<undef> is valid; use argument count (not definedness of the
third argument) to distinguish shorthand from longhand.

=head3 API SPECIFICATION

=head4 Input

    package    -- Str
    dependency -- Str
    value      -- Any (including undef)

=head4 Output

    returns: undef

=head3 MESSAGES

  "Package and dependency are required for injection" -- missing name

=cut
785
786sub inject {
787
55
99557
        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
55
132
        if (@_ == 2 && defined $_[0] && $_[0] =~ /^(.*)::([^:]+)$/) {
793
12
21
                ($package, $dependency, $mock_object) = ($1, $2, $_[1]);
794        } else {
795
43
40
                ($package, $dependency, $mock_object) = @_;
796        }
797
798
55
122
        croak 'Package and dependency are required for injection'
799                unless $package && $dependency;
800
801
46
43
        my $full = "${package}::${dependency}";
802
803
46
36
        my ($orig, $orig_existed);
804        {
805
23
23
23
46
30
24
687
31
                no strict 'refs';    ## no critic (ProhibitNoStrict)
806
46
46
29
85
                $orig_existed = defined(&{$full}) ? 1 : 0;
807
46
46
29
47
                $orig         = \&{$full};
808        }
809
46
46
33
49
        push @{ $mocked{$full} }, $orig;
810
811
46
35
62
615
        my $wrapper = sub { $mock_object };
812
813        {
814
23
23
23
46
32
18
291
28
                no warnings 'redefine';
815
23
23
23
31
14
5645
                no strict 'refs';    ## no critic (ProhibitNoStrict)
816
46
46
30
68
                *{$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
46
46
31
100
        push @{ $mock_meta{$full} }, {
822                type             => $TYPE // _T_INJECT,
823                installed_at     => _caller_info(),
824                original_existed => $orig_existed,
825        };
826
827
46
52
        return;
828}
829
830 - 858
=head2 inject_all

Inject multiple dependencies into a package in one call.

    inject_all('My::Service', {
        DB     => $mock_db,
        Logger => $mock_logger,
    });

An empty hashref is a no-op. Each pair is equivalent to a separate
C<inject()> call and participates in the same mock stack.

=head3 API SPECIFICATION

=head4 Input

    package      -- Str
    dependencies -- HashRef

=head4 Output

    returns: undef

=head3 MESSAGES

  "inject_all requires a package name"            -- undef or empty package
  "inject_all requires a hashref of dependencies" -- second arg not a HashRef

=cut
859
860sub inject_all {
861
27
90632
        my ($package, $deps) = @_;
862
863
27
85
        croak 'inject_all requires a package name'
864                unless defined $package && length $package;
865
866
19
43
        croak 'inject_all requires a hashref of dependencies'
867                unless ref $deps eq 'HASH';
868
869
12
28
        inject($package, $_, $deps->{$_}) for keys %$deps;
870
871
12
17
        return;
872}
873
874 - 905
=head2 intercept_new

Intercept the C<new> constructor of a class.

    intercept_new 'My::Service' => $stub_obj;
    intercept_new 'My::Service' => sub { My::Double->new(@_[1..$#_]) };

When given a plain value (including undef), every call to
C<< My::Service->new >> returns that value. When given a coderef, every
call invokes the coderef with the original arguments (including the class
name as the first argument) and returns its result.

This is a thin wrapper around C<mock()>; C<restore_all()>, C<unmock()>,
and C<diagnose_mocks()> all work identically.

=head3 API SPECIFICATION

=head4 Input

    class   -- Str (non-empty)
    factory -- Any; CodeRef invoked per call, or scalar returned verbatim

=head4 Output

    returns: undef

=head3 MESSAGES

  "intercept_new requires a class name"                    -- undef/empty class
  "intercept_new requires a replacement object or coderef" -- factory missing

=cut
906
907sub intercept_new {
908
37
107851
        my ($class, $factory) = @_;
909
910
37
105
        croak 'intercept_new requires a class name'
911                unless defined $class && length $class;
912
29
60
        croak 'intercept_new requires a replacement object or coderef'
913                if @_ < 2;
914
915        my $replacement = ref($factory) eq 'CODE'
916                ? $factory
917
25
20
42
41
                : sub { $factory };
918
919
25
21
        local $TYPE = _T_INTERCEPT_NEW;
920
25
40
        mock("${class}::new", $replacement);
921
922
25
27
        return;
923}
924
925 - 988
=head2 mock_core

Override a CORE Perl builtin globally via C<CORE::GLOBAL>.

    # Intercept 'warn' for code compiled after this point
    mock_core 'warn' => sub {
        my ($call_warn, @msgs) = @_;
        push @captured, @msgs;   # capture without emitting
    };

    # Call through to the real builtin via $call_builtin
    mock_core 'stat' => sub {
        my ($call_stat, $file) = @_;
        return $call_stat->($file);   # delegates to CORE::stat
    };

    unmock 'CORE::GLOBAL::warn';   # peel one layer
    restore_all();                 # drain all layers

The replacement receives C<($call_builtin, @original_args)>, mirroring the
C<around()> API.  C<$call_builtin> is a coderef that calls C<CORE::$name>
directly, bypassing any other C<CORE::GLOBAL> override.

The override is installed in C<CORE::GLOBAL::$name>, which is Perl's
documented mechanism for intercepting named builtins.  It affects all
packages globally.

B<Compile-time semantics:> C<CORE::GLOBAL> overrides are visible to code
compiled I<after> the override is installed.  To intercept calls in a module
under test, install the mock I<before> loading that module (a C<BEGIN> block
works).  Already-compiled call sites (including direct calls in the current
test file) are not affected at runtime.  Use string C<eval> when you need
code compiled in the same test run to see the override.

The wrapper carries the same prototype as C<CORE::$name> so that call-site
argument binding (such as the C<_> prototype that reads C<$_> when no
argument is given) is preserved.

Participates in the same LIFO mock stack as C<mock()>.  C<unmock>,
C<restore()>, and C<restore_all()> accept C<'CORE::GLOBAL::$name'> as the
target.  C<diagnose_mocks()> records the layer type as C<'mock_core'>.

B<Limitation:> builtins whose prototype begins with C<&> (C<sort>, C<map>,
C<grep>) require a literal code block at the call site and cannot be wrapped.

=head3 API SPECIFICATION

=head4 Input

    name        -- Str, CORE builtin name (no 'CORE::' prefix required)
    replacement -- CodeRef; receives ($call_builtin, @original_args)

=head4 Output

    returns: undef

=head3 MESSAGES

  "mock_core requires a builtin name and a replacement coderef" -- wrong arg types
  "mock_core: '$name' is not a valid identifier"               -- name has punctuation
  "mock_core: '$name' is not an overridable Perl builtin"      -- unknown builtin
  "mock_core: cannot build CORE::$name delegator: ..."         -- eval failed

=cut
989
990sub mock_core {
991
14
84470
        my ($name, $replacement) = @_;
992
993
14
39
        croak 'mock_core requires a builtin name and a replacement coderef'
994                unless defined $name && ref($replacement) eq 'CODE';
995
996
11
10
        $name =~ s/^CORE:://;    # tolerate an optional 'CORE::' prefix
997
998
11
24
        croak "mock_core: '$name' is not a valid identifier"
999                unless $name =~ /^\w+$/;
1000
10
7
        croak "mock_core: '$name' is not an overridable Perl builtin"
1001                unless _is_core_overridable($name);
1002
1003
9
9
9
7
19
9
        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
9
17
        my $args      = (defined $core_proto && $core_proto eq '_') ? '$_[0]' : '@_';
1012
9
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
1
349
3
1
25
2
1
23
2
1
19
3
1
19
2
1
13
3
1
21
2
1
24
2
1
18
2
1
17
        my $call_core = eval "sub { no warnings 'syntax'; CORE::$name($args) }";  ## no critic (ProhibitStringyEval)
1013
9
14
        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
9
8
10
208
        my $wrapper        = sub { $replacement->($call_core, @_) };
1023
9
9
        my $effective_proto = defined($core_proto) ? $core_proto : '@';
1024
9
18
        &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
9
8
        my $full = "CORE::GLOBAL::$name";
1029
1030
9
3
        my ($orig, $orig_existed);
1031        {
1032
23
23
23
9
50
17
639
8
                no strict 'refs';    ## no critic (ProhibitNoStrict)
1033
9
9
3
21
                $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
9
1
9
2
                $orig = $orig_existed ? \&{$full} : undef;
1041        }
1042
9
9
4
11
        push @{ $mocked{$full} }, $orig;
1043
1044        {
1045
23
23
23
9
35
19
357
6
                no warnings 'redefine', 'prototype';
1046
23
23
23
30
17
11962
                no strict 'refs';    ## no critic (ProhibitNoStrict)
1047
9
9
3
16
                *{$full} = $wrapper;
1048        }
1049
1050
9
9
6
22
        push @{ $mock_meta{$full} }, {
1051                type             => $TYPE // _T_MOCK_CORE,
1052                installed_at     => _caller_info(),
1053                original_existed => $orig_existed,
1054        };
1055
1056
9
9
        return;
1057}
1058
1059 - 1080
=head2 restore_all

Restore all mocked methods and injected dependencies.

    restore_all();            # restore everything
    restore_all 'My::Module'; # restore only My::Module's mocks

When called with a package name, only mocks whose fully-qualified names
begin with that package are restored. The call-order log is pruned to
remove entries for the restored package.

=head3 API SPECIFICATION

=head4 Input

    package -- Str, optional

=head4 Output

    returns: undef

=cut
1081
1082sub restore_all {
1083
360
95025
        my $arg = $_[0];
1084
1085
360
396
        if (defined $arg) {
1086
11
9
                my $package = $arg;
1087
1088
11
18
                for my $full_method (keys %mocked) {
1089
18
119
                        next unless $full_method =~ /^\Q$package\E::/;
1090
10
16
                        _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
10
22
                        delete $mocked{$full_method};
1094
10
16
                        delete $mock_meta{$full_method};
1095                }
1096
1097                # Remove call_log entries for the restored package
1098
11
7
15
28
                @call_log = grep { $_ !~ /^\Q$package\E::/ } @call_log;
1099
1100
11
14
                return;
1101        }
1102
1103        # Global restore: revert every tracked method to its saved state
1104
349
523
        _drain_and_restore($_) for keys %mocked;
1105
1106
349
388
        %mocked    = ();
1107
349
428
        %mock_meta = ();
1108
349
288
        @call_log  = ();
1109
1110
349
393
        return;
1111}
1112
1113 - 1135
=head2 restore

Restore all mock layers for a single method target.

    restore 'My::Module::method';

If the method was never mocked this is a no-op.

=head3 API SPECIFICATION

=head4 Input

    target -- Str

=head4 Output

    returns: undef

=head3 MESSAGES

  "restore requires a target" -- undef target

=cut
1136
1137sub restore {
1138
13
8211
        my $target = $_[0];
1139
1140
13
36
        croak 'restore requires a target' unless defined $target;
1141
1142
10
12
        my ($package, $method) = _parse_target($target);
1143
10
9
        my $full_method = "${package}::${method}";
1144
1145
10
19
        return unless exists $mocked{$full_method};
1146
1147
6
10
        _drain_and_restore($full_method);
1148
6
6
        delete $mocked{$full_method};
1149
6
9
        delete $mock_meta{$full_method};
1150
1151
6
7
        return;
1152}
1153
1154 - 1175
=head2 mock_return

Mock a method to always return a fixed value.

    mock_return 'My::Module::method' => 42;

=head3 API SPECIFICATION

=head4 Input

    target -- Str
    value  -- Any

=head4 Output

    returns: undef

=head3 MESSAGES

  "mock_return requires a target and a value" -- target undefined

=cut
1176
1177sub mock_return {
1178
38
109712
        my ($target, $value) = @_;
1179
1180
38
72
        croak 'mock_return requires a target and a value' unless defined $target;
1181
1182
35
39
        local $TYPE = _T_MOCK_RETURN;
1183
35
21
60
308
        mock $target => sub { $value };
1184
1185
35
33
        return;
1186}
1187
1188 - 1209
=head2 mock_exception

Mock a method to always throw an exception.

    mock_exception 'My::Module::method' => 'something went wrong';

=head3 API SPECIFICATION

=head4 Input

    target  -- Str
    message -- Str

=head4 Output

    returns: undef

=head3 MESSAGES

  "mock_exception requires a target and an exception message" -- either missing

=cut
1210
1211sub mock_exception {
1212
18
11679
        my ($target, $message) = @_;
1213
1214
18
85
        croak 'mock_exception requires a target and an exception message'
1215                unless defined $target && defined $message;
1216
1217
11
12
        local $TYPE = _T_MOCK_EXCEPT;
1218
11
8
21
1003
        mock $target => sub { croak $message };
1219
1220
11
10
        return;
1221}
1222
1223 - 1245
=head2 mock_sequence

Mock a method to return a sequence of values over successive calls.
The last value repeats when the sequence is exhausted.

    mock_sequence 'My::Module::method' => (1, 2, 3);

=head3 API SPECIFICATION

=head4 Input

    target -- Str
    values -- Array (one or more)

=head4 Output

    returns: undef

=head3 MESSAGES

  "mock_sequence requires a target and at least one value" -- empty value list

=cut
1246
1247sub mock_sequence {
1248
20
16570
        my ($target, @values) = @_;
1249
1250
20
57
        croak 'mock_sequence requires a target and at least one value'
1251                unless defined $target && @values;
1252
1253
16
17
        my @queue = @values;
1254
1255
16
11
        local $TYPE = _T_MOCK_SEQ;
1256        mock $target => sub {
1257
30
87
                return $queue[0] if @queue == 1;
1258
8
15
                return shift @queue;
1259
16
41
        };
1260
1261
16
16
        return;
1262}
1263
1264 - 1296
=head2 mock_once

Install a mock that fires exactly once. After the first call the previous
implementation is automatically restored.

    mock_once 'My::Module::method' => sub { 'temporary' };

=head3 API SPECIFICATION

=head4 Input

    target -- Str
    code   -- CodeRef

=head4 Output

    returns: undef

=head3 MESSAGES

  "mock_once requires a target and a coderef" -- missing or non-CODE factory

=head3 PSEUDOCODE

    parse target → (package, method)
    wrapper = sub {
        result = code(@_)
        unmock(package, method)   -- pop this very layer
        return result
    }
    install wrapper via mock() with TYPE='mock_once'

=cut
1297
1298sub mock_once {
1299
24
20549
        my ($target, $code) = @_;
1300
1301
24
76
        croak 'mock_once requires a target and a coderef'
1302                unless defined $target && ref($code) eq 'CODE';
1303
1304
19
22
        my ($package, $method) = _parse_target($target);
1305
1306        my $wrapper = sub {
1307
16
33
                my @result = $code->(@_);
1308
16
33
                Test::Mockingbird::unmock($package, $method);
1309
16
53
                return wantarray ? @result : $result[0];
1310
19
34
        };
1311
1312
19
17
        local $TYPE = _T_MOCK_ONCE;
1313
19
24
        mock $target => $wrapper;
1314
1315
19
19
        return;
1316}
1317
1318 - 1341
=head2 assert_call_order

Assert that the named methods were called in left-to-right order.

    assert_call_order('A::fetch', 'B::process', 'C::save');

Produces one TAP ok/not-ok line and returns a boolean. Intervening calls
to other methods are ignored.

=head3 API SPECIFICATION

=head4 Input

    methods -- Array of Str (two or more fully-qualified names)

=head4 Output

    returns: Bool

=head3 MESSAGES

  "assert_call_order requires at least two method names" -- fewer than two given

=cut
1342
1343sub assert_call_order {
1344
33
4565
        my @expected = @_;
1345
1346
33
58
        croak 'assert_call_order requires at least two method names'
1347                unless @expected >= 2;
1348
1349
29
21
        my $pos = 0;
1350
29
25
        for my $logged (@call_log) {
1351
59
61
                if ($logged eq $expected[$pos]) {
1352
47
26
                        $pos++;
1353
47
46
                        last if $pos == @expected;
1354                }
1355        }
1356
1357
29
36
        my $ok = ($pos == @expected);
1358
1359
29
69
        require Test::More;
1360
29
34
        if ($ok) {
1361
19
38
                Test::More::pass("call order: " . join(' -> ', @expected));
1362        } else {
1363
10
25
                Test::More::fail("call order: " . join(' -> ', @expected));
1364
10
5777
                Test::More::diag(
1365                        "Expected '$expected[$pos]' next but it was not in the call log"
1366                );
1367        }
1368
1369
29
5726
        return $ok;
1370}
1371
1372 - 1390
=head2 clear_call_log

Clear the call-order log without restoring mocks or spies.

    clear_call_log();

C<restore_all()> also clears the log automatically.

=head3 API SPECIFICATION

=head4 Input

    none

=head4 Output

    returns: undef

=cut
1391
1392sub clear_call_log {
1393
7
6587
        @call_log = ();
1394
7
9
        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
1406sub _record_call {
1407
1
3
        push @call_log, $_[0];
1408
1
2
        return;
1409}
1410
1411 - 1431
=head2 diagnose_mocks

Return a structured hashref of all currently active mock layers.

    my $diag = diagnose_mocks();
    # $diag->{'My::Pkg::method'} = {
    #   depth            => 1,
    #   layers           => [ { type => 'mock_return', installed_at => '...' } ],
    # }

=head3 API SPECIFICATION

=head4 Input

    none

=head4 Output

    returns: HashRef

=cut
1432
1433sub diagnose_mocks {
1434
85
5804
        my %report;
1435
1436
85
130
        for my $full_method (sort keys %mocked) {
1437
81
90
                my $layers = $mock_meta{$full_method} // [];
1438                $report{$full_method} = {
1439
81
254
                        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
81
54
                        original_existed => (@$layers && $layers->[0]{original_existed}) ? 1 : 0,
1444                };
1445        }
1446
1447
85
100
        return \%report;
1448}
1449
1450 - 1464
=head2 diagnose_mocks_pretty

Return a human-readable multi-line string of all active mock layers.

=head3 API SPECIFICATION

=head4 Input

    none

=head4 Output

    returns: Str

=cut
1465
1466sub diagnose_mocks_pretty {
1467
8
75998
        my $diag = diagnose_mocks();
1468
8
6
        my @out;
1469
1470
8
12
        for my $full_method (sort keys %$diag) {
1471
10
8
                my $entry = $diag->{$full_method};
1472
10
11
                push @out, "$full_method:";
1473
10
12
                push @out, "  depth: $entry->{depth}";
1474
10
10
                push @out, "  original_existed: $entry->{original_existed}";
1475
10
10
6
10
                for my $layer (@{ $entry->{layers} }) {
1476                        push @out, sprintf "  - type: %-14s installed_at: %s",
1477
10
22
                                $layer->{type}, $layer->{installed_at};
1478                }
1479
10
8
                push @out, '';
1480        }
1481
1482
8
27
        return join "\n", @out;
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.
1494sub _drain_and_restore {
1495
381
256
        my $full_method = $_[0];
1496
1497
381
235
        my $final_prev;
1498
381
850
248
709
        while (@{ $mocked{$full_method} }) {
1499
469
469
287
384
                $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
381
310
        if (defined $final_prev) {
1506
23
23
23
61
19
417
                no warnings 'redefine';
1507
23
23
23
35
12
941
                no strict 'refs';    ## no critic (ProhibitNoStrict)
1508
374
374
208
997
                *{$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
7
17
                my ($bname) = ($full_method =~ /::([^:]+)$/);
1516
23
23
23
31
18
5778
                no strict 'refs';    ## no critic (ProhibitNoStrict)
1517
7
9
                delete $CORE::GLOBAL::{$bname};
1518        }
1519
1520
381
381
        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
1529sub _parse_target {
1530
229
83736
        my ($arg1, $arg2) = @_;
1531
1532        # Shorthand: single 'Pkg::method' string -- arg2 is absent (undef)
1533
229
713
        if (defined $arg1 && !defined $arg2 && $arg1 =~ /^(.*)::([^:]+)$/) {
1534
184
314
                return ($1, $2);
1535        }
1536
1537
45
55
        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"
1549sub _caller_info {
1550
567
1657
        my $level = 1;
1551
567
554
        while (my @info = caller($level)) {
1552
897
5907
                last unless $info[0] =~ /^Test::Mockingbird/;
1553
330
349
                $level++;
1554        }
1555
567
613
        my @info = caller($level);
1556
567
3719
        return defined $info[1] ? "$info[1] line $info[2]" : '(unknown)';
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
1565sub _get_prototype {
1566
11
8566
        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
11
52
        croak "Invalid fully-qualified name '$full'"
1571                unless $full =~ /^[A-Za-z_]\w*(?:::[A-Za-z_]\w*)+$/;
1572
1573
6
14
        my ($pkg, $sub) = $full =~ /^(.*)::([^:]+)$/;
1574
6
27
        my $code = $pkg->can($sub) or return;
1575
4
9
        return prototype($code);
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")
1585sub _is_core_overridable {
1586
10
7
        my $name = $_[0];
1587
10
8
        local $@;
1588
10
10
9
5
34
6
        eval { my $p = prototype("CORE::$name"); 1 };
1589
10
14
        return !$@;
1590}
1591
1592 - 1827
=head1 SUPPORT

This module is provided as-is without any warranty.

Please report bugs at L<https://github.com/nigelhorne/Test-Mockingbird/issues>.

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 SEE ALSO

=over 4

=item * L<Test Dashboard|https://nigelhorne.github.io/Test-Mockingbird/coverage/>

=item * L<Test::Mockingbird::Async>

=item * L<Test::Mockingbird::DeepMock>

=item * L<Test::Mockingbird::TimeTravel>

=back

=head1 REPOSITORY

L<https://github.com/nigelhorne/Test-Mockingbird>

=head1 FORMAL SPECIFICATION

=head2 mock

    mock ≙
      âˆ€ target : Str; replacement : CodeRef •
        pre  target ≠ '' ∧ defined(replacement)
        post mocked'[target] = ⟨saved(target)⟩ ⌢ mocked[target]
             âˆ§ sym_table'[target].CODE = replacement
             âˆ§ prototype(replacement) = prototype(saved(target))

=head2 unmock

    unmock ≙
      âˆ€ target : Str •
        let prev = head(mocked[target]) •
          post mocked'[target] = tail(mocked[target])
               âˆ§ sym_table'[target].CODE = prev
               âˆ§ mock_meta'[target] = tail(mock_meta[target])

=head2 before

    before ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙ hook(@args); orig(@args)

=head2 after

    after ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙ let ret = orig(@args) • hook(@args); ret

=head2 around

    around ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙ hook(orig, @args)

=head2 mock_core

    mock_core ≙
      âˆ€ name : Str; replacement : CodeRef •
        pre  _is_core_overridable(name) ∧ ref(replacement) = 'CODE'
        let  call_core = eval("sub { CORE::name(@_) }") •
        let  wrapper   = sub { replacement(call_core, @_) } •
          post CORE::GLOBAL::name.CODE = wrapper
               âˆ§ prototype(wrapper) = prototype(CORE::name)
               âˆ§ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"]

=head2 mock_scoped

    mock_scoped ≙
      install all mocks via mock()
      âˆ§ return Guard(full_methods)
      âˆ§ Guard.DESTROY ⇒ ∀ m ∈ full_methods • unmock(m)

=head2 spy

    spy ≙
      âˆ€ target : Str •
        pre  defined(target)
        post sym_table'[target].CODE = wrapper(orig)
             âˆ§ wrapper: @args → (calls' = calls ⌢ ⟨[target, @args]⟩ ∧ orig(@args))

=head2 inject

    inject ≙
      âˆ€ pkg : Str; dep : Str; val : Any •
        pre  pkg ≠ '' ∧ dep ≠ ''
        post sym_table'["${pkg}::${dep}"].CODE = sub { val }

=head2 inject_all

    inject_all ≙
      âˆ€ pkg : Str; deps : HashRef •
        post ∀ (k,v) ∈ deps • inject(pkg, k, v)

=head2 intercept_new

    intercept_new ≙
      âˆ€ class : Str; factory : Any •
        pre  class ≠ '' ∧ @args ≥ 2
        let  rep = (factory : CodeRef) ? factory : sub { factory } •
          post mock("${class}::new", rep)

=head2 restore_all

    restore_all ≙
      global: mocked' = {} ∧ mock_meta' = {} ∧ call_log' = []
      scoped: ∀ target ∈ dom(mocked) • target =~ /^pkg::/ ⇒ unmock_all(target)
              âˆ§ call_log' = [ e ∈ call_log | e !~ /^pkg::/ ]

=head2 restore

    restore ≙
      âˆ€ target : Str •
        pre  defined(target)
        post mocked[target] = []

=head2 mock_return

    mock_return ≙
      âˆ€ target : Str; value : Any •
        post sym_table'[target].CODE = sub { value }

=head2 mock_exception

    mock_exception ≙
      âˆ€ target : Str; msg : Str •
        post sym_table'[target].CODE = sub { croak msg }

=head2 mock_sequence

    mock_sequence ≙
      âˆ€ target : Str; values : Seq(Any) •
        pre  |values| ≥ 1
        post let queue = values •
          sym_table'[target].CODE = sub { head(queue) if |queue|=1 else shift(queue) }

=head2 mock_once

    mock_once ≙
      âˆ€ target : Str; code : CodeRef •
        post sym_table'[target] = sub {
          result = code(@args)
          unmock(target)
          return result
        }

=head2 assert_call_order

    assert_call_order ≙
      âˆ€ expected : Seq(Str) •
        pre  |expected| ≥ 2
        post result = (∀ i • ∃ p_i : â„• | p_0 < p_1 < … ∧ call_log[p_i] = expected[i])

=head2 clear_call_log

    clear_call_log ≙ post call_log' = []

=head2 diagnose_mocks

    diagnose_mocks ≙
      returns { target ↦ { depth, layers } | target ∈ dom(mocked) }

=head2 diagnose_mocks_pretty

    diagnose_mocks_pretty ≙ stringify(diagnose_mocks())

=head2 before

    before ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙ hook(@args); orig(@args)

=head2 after

    after ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙
                   let ret = orig(@args) •
                   hook(@args);
                   ret

=head2 around

    around ≙
      âˆ€ target : Str; hook : CodeRef •
        pre  target ≠ '' ∧ ref(hook) = 'CODE'
        let orig = sym_table[target].CODE •
          post sym_table'[target].CODE = wrapper
               âˆ§ wrapper(@args) ≙ hook(orig, @args)

=head2 mock_core

    mock_core ≙
      âˆ€ name : Str; replacement : CodeRef •
        pre  _is_core_overridable(name) ∧ ref(replacement) = 'CODE'
        let  call_core = eval("sub { CORE::name(@_) }") •
        let  wrapper   = sub { replacement(call_core, @_) } •
          post CORE::GLOBAL::name.CODE = wrapper
               âˆ§ prototype(wrapper) = prototype(CORE::name)
               âˆ§ mocked'["CORE::GLOBAL::name"] = ⟨wrapper⟩ ⌢ mocked["CORE::GLOBAL::name"]

=head1 LICENCE AND COPYRIGHT

Copyright 2025-2026 Nigel Horne.

Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.

=cut
1828
18291;
1830
1831package 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
1836sub new {
1837
27
47
        my ($class, @full_methods) = @_;
1838
27
63
        return bless { full_methods => \@full_methods }, $class;
1839}
1840
1841sub DESTROY {
1842
27
12492
        my $self = $_[0];
1843
27
27
20
52
        Test::Mockingbird::unmock($_) for @{ $self->{full_methods} };
1844
27
44
        return;
1845}
1846
18471;