| File: | blib/lib/Test/Mockingbird.pm |
| Coverage: | 97.7% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package 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. | |||||
| 19 | use 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 | ||||||
| 35 | our @EXPORT = qw( | |||||
| 36 | mock | |||||
| 37 | unmock | |||||
| 38 | mock_scoped | |||||
| 39 | mock_core | |||||
| 40 | before | |||||
| 41 | after | |||||
| 42 | around | |||||
| 43 | spy | |||||
| 44 | inject | |||||
| 45 | inject_all | |||||
| 46 | intercept_new | |||||
| 47 | restore | |||||
| 48 | restore_all | |||||
| 49 | mock_return | |||||
| 50 | mock_exception | |||||
| 51 | mock_sequence | |||||
| 52 | mock_once | |||||
| 53 | diagnose_mocks | |||||
| 54 | diagnose_mocks_pretty | |||||
| 55 | assert_call_order | |||||
| 56 | clear_call_log | |||||
| 57 | ); | |||||
| 58 | ||||||
| 59 | # $TYPE is set via 'local' by sugar functions before delegating to mock() | |||||
| 60 | # or inject() so that diagnose_mocks() records the correct layer type. | |||||
| 61 | # External modules (e.g. Test::Mockingbird::Async) use the same mechanism. | |||||
| 62 | our $TYPE; | |||||
| 63 | ||||||
| 64 | # Internal mocking state -- module-level lexicals. | |||||
| 65 | my %mocked; # full_method => [ stack of coderefs (or undef stubs) ] | |||||
| 66 | my %mock_meta; # full_method => [ { type => ..., installed_at => ... }, ... ] | |||||
| 67 | my @call_log; # ordered log of every spied call | |||||
| 68 | ||||||
| 69 - 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 | ||||||
| 81 | our $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 | ||||||
| 239 | sub 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 | ||||||
| 324 | sub 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 | ||||||
| 403 | sub 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 | ||||||
| 477 | sub 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 | ||||||
| 564 | sub 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 | ||||||
| 630 | sub 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 | ||||||
| 708 | sub 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 | ||||||
| 786 | sub 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 | ||||||
| 860 | sub 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 | ||||||
| 907 | sub 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 | ||||||
| 990 | sub 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 | ||||||
| 1082 | sub 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 | ||||||
| 1137 | sub 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 | ||||||
| 1177 | sub 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 | ||||||
| 1211 | sub 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 | ||||||
| 1247 | sub 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 | ||||||
| 1298 | sub 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 | ||||||
| 1343 | sub 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 | ||||||
| 1392 | sub 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 | |||||
| 1406 | sub _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 | ||||||
| 1433 | sub 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 | ||||||
| 1466 | sub 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. | |||||
| 1494 | sub _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 | |||||
| 1529 | sub _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" | |||||
| 1549 | sub _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 | |||||
| 1565 | sub _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") | |||||
| 1585 | sub _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 | ||||||
| 1829 | 1; | |||||
| 1830 | ||||||
| 1831 | package Test::Mockingbird::Guard; | |||||
| 1832 | ||||||
| 1833 | # Guard object returned by mock_scoped. Stores a list of fully-qualified | |||||
| 1834 | # method names and calls unmock() on each when destroyed. | |||||
| 1835 | ||||||
| 1836 | sub new { | |||||
| 1837 | 27 | 47 | my ($class, @full_methods) = @_; | |||
| 1838 | 27 | 63 | return bless { full_methods => \@full_methods }, $class; | |||
| 1839 | } | |||||
| 1840 | ||||||
| 1841 | sub 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 | ||||||
| 1847 | 1; | |||||