<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Test2::Tools::Mock;
use strict;
use warnings;

use Carp qw/croak/;
use Scalar::Util qw/blessed reftype weaken/;
use Test2::Util qw/try/;
use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/;

use Test2::Mock();

use base 'Exporter';

our $VERSION = '0.000162';

our @CARP_NOT = (__PACKAGE__, 'Test2::Mock');
our @EXPORT = qw/mock mocked/;
our @EXPORT_OK = qw{
    mock_obj mock_class
    mock_do  mock_build
    mock_accessor mock_accessors
    mock_getter   mock_getters
    mock_setter   mock_setters
    mock_building
};

my %HANDLERS;
my %MOCKS;
my @BUILD;

sub add_handler {
    my $class = shift;
    my ($for, $code) = @_;

    croak "Must specify a package for the mock handler"
        unless $for;

    croak "Handlers must be code references (got: $code)"
        unless $code &amp;&amp; ref($code) eq 'CODE';

    push @{$HANDLERS{$for}} =&gt; $code;
}

sub mock_building {
    return unless @BUILD;
    return $BUILD[-1];
}

sub mocked {
    my $proto = shift;
    my $class = blessed($proto) || $proto;

    # Check if we have any mocks.
    my $set = $MOCKS{$class} || return;

    # Remove dead mocks (undef due to weaken)
    pop @$set while @$set &amp;&amp; !defined($set-&gt;[-1]);

    # Remove the list if it is empty
    delete $MOCKS{$class} unless @$set;

    # Return the controls (may be empty list)
    return @$set;
}

sub _delegate {
    my ($args) = @_;

    my $do    = __PACKAGE__-&gt;can('mock_do');
    my $obj   = __PACKAGE__-&gt;can('mock_obj');
    my $class = __PACKAGE__-&gt;can('mock_class');
    my $build = __PACKAGE__-&gt;can('mock_build');

    return $obj unless @$args;

    my ($proto, $arg1) = @$args;

    return $obj if ref($proto) &amp;&amp; !blessed($proto);

    if (blessed($proto)) {
        return $class unless $proto-&gt;isa('Test2::Mock');
        return $build if $arg1 &amp;&amp; ref($arg1) &amp;&amp; reftype($arg1) eq 'CODE';
    }

    return $class if $proto =~ m/(?:::|')/;
    return $class if $proto =~ m/^_*[A-Z]/;

    return $do if Test2::Mock-&gt;can($proto);

    if (my $sub = __PACKAGE__-&gt;can("mock_$proto")) {
        shift @$args;
        return $sub;
    }

    return undef;
}

sub mock {
    croak "undef is not a valid first argument to mock()"
        if @_ &amp;&amp; !defined($_[0]);

    my $sub = _delegate(\@_);

    croak "'$_[0]' does not look like a package name, and is not a valid control method"
        unless $sub;

    $sub-&gt;(@_);
}

sub mock_build {
    my ($control, $sub) = @_;

    croak "mock_build requires a Test2::Mock object as its first argument"
        unless $control &amp;&amp; blessed($control) &amp;&amp; $control-&gt;isa('Test2::Mock');

    croak "mock_build requires a coderef as its second argument"
        unless $sub &amp;&amp; ref($sub) &amp;&amp; reftype($sub) eq 'CODE';

    push @BUILD =&gt; $control;
    my ($ok, $err) = &amp;try($sub);
    pop @BUILD;
    die $err unless $ok;
}

sub mock_do {
    my ($meth, @args) = @_;

    croak "Not currently building a mock"
        unless @BUILD;

    my $build = $BUILD[-1];

    croak "'$meth' is not a valid action for mock_do()"
        if $meth =~ m/^_/ || !$build-&gt;can($meth);

    $build-&gt;$meth(@args);
}

sub mock_obj {
    my ($proto) = @_;

    if ($proto &amp;&amp; ref($proto) &amp;&amp; reftype($proto) ne 'CODE') {
        shift @_;
    }
    else {
        $proto = {};
    }

    my $class = _generate_class();
    my $control;

    if (@_ == 1 &amp;&amp; reftype($_[0]) eq 'CODE') {
        my $orig = shift @_;
        $control = mock_class(
            $class,
            sub {
                my $c = mock_building;

                # We want to do these BEFORE anything that the sub may do.
                $c-&gt;block_load(1);
                $c-&gt;purge_on_destroy(1);
                $c-&gt;autoload(1);

                $orig-&gt;(@_);
            },
        );
    }
    else {
        $control = mock_class(
            $class,
            # Do these before anything the user specified.
            block_load       =&gt; 1,
            purge_on_destroy =&gt; 1,
            autoload         =&gt; 1,
            @_,
        );
    }

    my $new = bless($proto, $control-&gt;class);

    # We need to ensure there is a reference to the control object, and we want
    # it to go away with the object.
    $new-&gt;{'~~MOCK~CONTROL~~'} = $control;
    return $new;
}

sub _generate_class {
    my $prefix = __PACKAGE__;

    for (1 .. 100) {
        my $postfix = join '', map { chr(rand(26) + 65) } 1 .. 32;
        my $class = $prefix . '::__TEMP__::' . $postfix;
        my $file = $class;
        $file =~ s{::}{/}g;
        $file .= '.pm';
        next if $INC{$file};
        my $stash = do { no strict 'refs'; \%{"${class}\::"} };
        next if keys %$stash;
        return $class;
    }

    croak "Could not generate a unique class name after 100 attempts";
}

sub mock_class {
    my $proto = shift;
    my $class = blessed($proto) || $proto;
    my @args = @_;

    my $void   = !defined(wantarray);

    my $callback = sub {
        my ($parent) = reverse mocked($class);
        my $control;

        if (@args == 1 &amp;&amp; ref($args[0]) &amp;&amp; reftype($args[0]) eq 'CODE') {
            $control = Test2::Mock-&gt;new(class =&gt; $class);
            mock_build($control, @args);
        }
        else {
            $control = Test2::Mock-&gt;new(class =&gt; $class, @args);
        }

        if ($parent) {
            $control-&gt;{parent} = $parent;
            weaken($parent-&gt;{child} = $control);
        }

        $MOCKS{$class} ||= [];
        push @{$MOCKS{$class}} =&gt; $control;
        weaken($MOCKS{$class}-&gt;[-1]);

        return $control;
    };

    return $callback-&gt;() unless $void;

    my $level = 0;
    my $caller;
    while (my @call = caller($level++)) {
        next if $call[0] eq __PACKAGE__;
        $caller = \@call;
        last;
    }

    my $handled;
    for my $handler (@{$HANDLERS{$caller-&gt;[0]}}) {
        $handled++ if $handler-&gt;(
            class   =&gt; $class,
            caller  =&gt; $caller,
            builder =&gt; $callback,
            args    =&gt; \@args,
        );
    }

    croak "mock_class should not be called in a void context without a registered handler"
        unless $handled;
}

sub mock_accessors {
    return map {( $_ =&gt; gen_accessor($_) )} @_;
}

sub mock_accessor {
    my ($field) = @_;
    return gen_accessor($field);
}

sub mock_getters {
    my ($prefix, @list) = @_;
    return map {( "$prefix$_" =&gt; gen_reader($_) )} @list;
}

sub mock_getter {
    my ($field) = @_;
    return gen_reader($field);
}

sub mock_setters {
    my ($prefix, @list) = @_;
    return map {( "$prefix$_" =&gt; gen_writer($_) )} @list;
}

sub mock_setter {
    my ($field) = @_;
    return gen_writer($field);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Tools::Mock - Class/Instance mocking for Test2.

=head1 DESCRIPTION

Mocking is often an essential part of testing. This library covers some of the
most common mocking needs. This plugin is heavily influenced by L&lt;Mock::Quick&gt;,
but with an improved API. This plugin is also intended to play well with other
plugins in ways L&lt;Mock::Quick&gt; would be unable to.

=head1 SYNOPSIS

    my $mock = mock 'Some::Class' =&gt; (
        track =&gt; $BOOL, # Enable/Disable tracking on subs defined below

        add =&gt; [
            new_method =&gt; sub { ... },
        ],
        override =&gt; [
            replace_method =&gt; sub { ... },
        ],
        set =&gt; [
            replace_or_inject =&gt; sub { ... },
        ],

        track =&gt; $bool, # enable/disable tracking again to affect mocks made after this point
        ..., # Argument keys may be repeated
    );

    Some::Class-&gt;new_method();        # Calls the newly injected method
    Some::Class-&gt;replace_method();    # Calls our replacement method.

    $mock-&gt;override(...) # Override some more

    $mock = undef; # Undoes all the mocking, restoring all original methods.

    my $simple_mock = mock {} =&gt; (
        add =&gt; [
            is_active =&gt; sub { ... }
        ]
    );

    $simple_mock-&gt;is_active();        # Calls our newly mocked method.

=head1 EXPORTS

=head2 DEFAULT

=over 4

=item mock

This is a one-stop shop function that delegates to one of the other methods
depending on how it is used. If you are not comfortable with a function that
has a lot of potential behaviors, you can use one of the other functions
directly.

=item @mocks = mocked($object)

=item @mocks = mocked($class)

Check if an object or class is mocked. If it is mocked the C&lt;$mock&gt; object(s)
(L&lt;Test2::Mock&gt;) will be returned.

=item $mock = mock $class =&gt; ( ... );

=item $mock = mock $instance =&gt; ( ... )

=item $mock = mock 'class', $class =&gt; ( ... )

These forms delegate to C&lt;mock_class()&gt; to mock a package. The third form is to
be explicit about what type of mocking you want.

=item $obj = mock()

=item $obj = mock { ... }

=item $obj = mock 'obj', ...;

These forms delegate to C&lt;mock_obj()&gt; to create instances of anonymous packages
where methods are vivified into existence as needed.

=item mock $mock =&gt; sub { ... }

=item mock $method =&gt; ( ... )

These forms go together, the first form will set C&lt;$mock&gt; as the current mock
build, then run the sub. Within the sub you can declare mock specifications
using the second form. The first form delegates to C&lt;mock_build()&gt;.

The second form calls the specified method on the current build. This second
form delegates to C&lt;mock_do()&gt;.

=back

=head2 BY REQUEST

=head3 DEFINING MOCKS

=over 4

=item $obj = mock_obj( ... )

=item $obj = mock_obj { ... } =&gt; ( ... )

=item $obj = mock_obj sub { ... }

=item $obj = mock_obj { ... } =&gt; sub { ... }

This method lets you quickly generate a blessed object. The object will be an
instance of a randomly generated package name. Methods will vivify as
read/write accessors as needed.

Arguments can be any method available to L&lt;Test2::Mock&gt; followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.

If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L&lt;/"BUILDING MOCKS"&gt; section).

=item $mock = mock_class $class =&gt; ( ... )

=item $mock = mock_class $instance =&gt; ( ... )

=item $mock = mock_class ... =&gt; sub { ... }

This will create a new instance of L&lt;Test2::Mock&gt; to control the package
specified. If you give it a blessed reference it will use the class of the
instance.

Arguments can be any method available to L&lt;Test2::Mock&gt; followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.

If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L&lt;/"BUILDING MOCKS"&gt; section).

=back

=head3 BUILDING MOCKS

=over 4

=item mock_build $mock =&gt; sub { ... }

Set C&lt;$mock&gt; as the current build, then run the specified code. C&lt;$mock&gt; will
no longer be the current build when the sub is complete.

=item $mock = mock_building()

Get the current building C&lt;$mock&gt; object.

=item mock_do $method =&gt; $args

Run the specified method on the currently building object.

=back

=head3 METHOD GENERATORS

=over 4

=item $sub = mock_accessor $field

Generate a read/write accessor for the specified field. This will generate a sub like the following:

    $sub = sub {
        my $self = shift;
        ($self-&gt;{$field}) = @_ if @_;
        return $self-&gt;{$field};
    };

=item $sub = mock_getter $field

Generate a read only accessor for the specified field. This will generate a sub like the following:

    $sub = sub {
        my $self = shift;
        return $self-&gt;{$field};
    };

=item $sub = mock_setter $field

Generate a write accessor for the specified field. This will generate a sub like the following:

    $sub = sub {
        my $self = shift;
        ($self-&gt;{$field}) = @_;
    };

=item %pairs = mock_accessors(qw/name1 name2 name3/)

Generates several read/write accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.

=item %pairs = mock_getters(qw/name1 name2 name3/)

Generates several read only accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.

=item %pairs = mock_setters(qw/name1 name2 name3/)

Generates several write accessors at once, returns key/value pairs where the
key is the field name, and the value is the coderef.

=back

=head1 MOCK CONTROL OBJECTS

    my $mock = mock(...);

Mock objects are instances of L&lt;Test2::Mock&gt;. See it for their methods.

=head1 SOURCE

The source code repository for Test2-Suite can be found at
L&lt;https://github.com/Test-More/Test2-Suite/&gt;.

=head1 MAINTAINERS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 AUTHORS

=over 4

=item Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;

=back

=head1 COPYRIGHT

Copyright 2018 Chad Granum E&lt;lt&gt;exodist@cpan.orgE&lt;gt&gt;.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L&lt;https://dev.perl.org/licenses/&gt;

=cut
</pre></body></html>