view release on metacpan or  search on metacpan

lib/Test/Mocha/Mock.pm  view on Meta::CPAN

package Test::Mocha::Mock;
# ABSTRACT: Mock objects
$Test::Mocha::Mock::VERSION = '0.67';
use parent 'Test::Mocha::SpyBase';
use strict;
use warnings;

use Test::Mocha::MethodCall;
use Test::Mocha::MethodStub;
use Test::Mocha::Util ();
use Types::Standard   ();
use if $] lt '5.025', 'UNIVERSAL::ref';

our $AUTOLOAD;

# Lookup table of classes for which mock isa() should return false
my %NOT_ISA =
  map { $_ => undef } ( 'Type::Tiny', 'Moose::Meta::TypeConstraint', );

# By default, isa(), DOES() and does() should return true for everything, and
# can() should return a reference to C<AUTOLOAD()> for all methods
my %DEFAULT_STUBS = (
    isa => Test::Mocha::MethodStub->new(
        name      => 'isa',
        args      => [Types::Standard::Str],
        responses => [ sub { 1 } ],
    ),
    DOES => Test::Mocha::MethodStub->new(
        name      => 'DOES',
        args      => [Types::Standard::Str],
        responses => [ sub { 1 } ],
    ),
    does => Test::Mocha::MethodStub->new(
        name      => 'does',
        args      => [Types::Standard::Str],
        responses => [ sub { 1 } ],
    ),
    ref => Test::Mocha::MethodStub->new(
        # ref() is a special stub because we use UNIVERSAL::ref which
        # allows us to call it as a method.
        name      => 'ref',
        args      => [],
        responses => [ sub { __PACKAGE__ } ],
    ),
    can => Test::Mocha::MethodStub->new(
        name      => 'can',
        args      => [Types::Standard::Str],
        responses => [
            sub {
                my ( $self, $method_name ) = @_;
                return sub {
                    $AUTOLOAD = $method_name;
                    goto &AUTOLOAD;
                };
            }
        ],
    ),
);

sub __new {
    # uncoverable pod
    my ( $class, $mocked_class ) = @_;

    my $args = $class->SUPER::__new;

    $args->{mocked_class} = $mocked_class;
    $args->{stubs}        = {
        map { $_ => [ $DEFAULT_STUBS{$_} ] }
          keys %DEFAULT_STUBS
    };
    return bless $args, $class;
}