File Coverage

blib/lib/Test/Mocha.pm

Criterion	Covered	Total	%
statement	167	169	98.8
branch	70	70	100.0
condition	8	9	88.8
subroutine	42	42	100.0
pod	14	17	100.0
total	301	307	99.0

use strict;
use warnings;

package Test::Mocha;
# ABSTRACT: Test Spy/Stub Framework
$Test::Mocha::VERSION = '0.61';

use Carp qw( croak );
use Exporter qw( import );
use Scalar::Util qw( blessed );
use Test::Mocha::CalledOk::Times;
use Test::Mocha::CalledOk::AtLeast;
use Test::Mocha::CalledOk::AtMost;
use Test::Mocha::CalledOk::Between;
use Test::Mocha::Mock;
use Test::Mocha::Types 'NumRange', Mock => { -as => 'MockType' };
use Test::Mocha::Util
  qw( getattr get_method_call is_called extract_method_name );
use Types::Standard qw( ArrayRef HashRef Num slurpy );

our @EXPORT = qw(
  mock
  class_mock
  stub
  returns
  throws
  executes
  called_ok
  times
  atleast
  atmost
  between
  verify
  inspect
  inspect_all
  clear
  SlurpyArray
  SlurpyHash
);

# croak() messages should not trace back to Mocha modules
$Carp::Internal{$_}++ foreach qw(
  Test::Mocha
  Test::Mocha::CalledOk
  Test::Mocha::Inspect
  Test::Mocha::Mock
  Test::Mocha::Util
  Test::Mocha::MethodStub
  Test::Mocha::Verify
);

sub mock {
    return Test::Mocha::Mock->new(@_);
}

sub stub (&@) {
    my ( $arg, @executions ) = @_;

    foreach (@executions) {
        croak 'stub() responses should be supplied using ',
          'returns(), throws() or executes()'
          if ref ne 'CODE';
    }

    $Test::Mocha::Mock::num_method_calls = 0;
    my $method_call = get_method_call($arg);
    my $stubs = getattr( $method_call->invocant, 'stubs' );
    unshift @{ $stubs->{ $method_call->name } }, $method_call;

    Test::Mocha::MethodStub->cast($method_call);
    push @{ getattr( $method_call, 'executions' ) }, @executions;
    return $method_call;  # for backwards compatibility
}

sub returns (@) {
    my (@return_values) = @_;
    return sub { $return_values[0] }
      if @return_values == 1;
    return sub { @return_values }
      if @return_values > 1;
    return sub { };       # if @return_values == 0
}

sub throws (@) {
    my (@exception) = @_;

    # check if first arg is a throwable exception
    return sub { $exception[0]->throw }
      if blessed( $exception[0] ) && $exception[0]->can('throw');

    return sub { croak @exception };

}

sub executes (&) {
    my ($callback) = @_;
    return $callback;
}

## no critic (RequireArgUnpacking,ProhibitMagicNumbers)
sub called_ok (&;@) {
    my $coderef = shift;
    my $called_ok;
    my $class;
    my $value;
    my $test_name;

    # unpack the args - different possibilities due to backwards compatibility
    if ( @_ == 1 ) {
        if ( ref $_[0] eq 'CODE' ) {
            $called_ok = $_[0];
        }
        else {
            $test_name = $_[0];
        }
    }
    elsif ( @_ == 2 ) {
        if ( ref $_[0] eq 'CODE' ) {
            ( $called_ok, $test_name ) = @_;
        }
        else {
            ( $class, $value ) = @_;
        }
    }
    elsif ( @_ == 3 ) {
        ( $class, $value, $test_name ) = @_;
    }

    $Test::Mocha::Mock::num_method_calls = 0;
    my $method_call = get_method_call($coderef);

    # v0.50 behaviour
    if ( defined $class ) {
        my %options = (
            times    => 'Test::Mocha::CalledOk::Times',
            atleast  => 'Test::Mocha::CalledOk::AtLeast',
            atmost   => 'Test::Mocha::CalledOk::AtMost',
            at_least => 'Test::Mocha::CalledOk::AtLeast',
            at_most  => 'Test::Mocha::CalledOk::AtMost',
            between  => 'Test::Mocha::CalledOk::Between',
        );
        croak "called_ok() was given an invalid option: '$class'"
          unless defined $options{$class};

        if ( $class ne 'between' ) {
            croak "'$class' option must be a number"
              unless Num->check($value);
        }
        else {
            croak "'$class' option must be an arrayref "
              . 'with 2 numbers in ascending order'
              unless NumRange->check($value);
        }

        $options{$class}->test( $method_call, $value, $test_name );
        return;
    }

    # current behaviour
    ## no critic (ProhibitAmpersandSigils)
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    $called_ok ||= ×(1);  # default if no times() is specified
    $called_ok->( $method_call, $test_name );
    return;
}
## use critic

## no critic (ProhibitBuiltinHomonyms)
sub times ($) {
    my ($n) = @_;
    croak 'times() must be given a number'
      unless Num->check($n);

    return sub {
        my ( $method_call, $test_name ) = @_;
        Test::Mocha::CalledOk::Times->test( $method_call, $n, $test_name );
    };
}
## use critic

sub atleast ($) {
    my ($n) = @_;
    croak 'atleast() must be given a number'
      unless Num->check($n);

    return sub {
        my ( $method_call, $test_name ) = @_;
        Test::Mocha::CalledOk::AtLeast->test( $method_call, $n, $test_name );
    };
}

sub atmost ($) {
    my ($n) = @_;
    croak 'atmost() must be given a number'
      unless Num->check($n);

    return sub {
        my ( $method_call, $test_name ) = @_;
        Test::Mocha::CalledOk::AtMost->test( $method_call, $n, $test_name );
    };
}

sub between ($$) {
    my ( $lower, $upper ) = @_;
    croak 'between() must be given 2 numbers in ascending order'
      unless NumRange->check( [ $lower, $upper ] );

    return sub {
        my ( $method_call, $test_name ) = @_;
        Test::Mocha::CalledOk::Between->test( $method_call, [ $lower, $upper ],
            $test_name );
    };
}

# verify() has been retained for backwards compatibility only

sub verify ($;@) {
    # uncoverable pod
    my ( $mock, %options ) = _get_called_ok_args(@_);

    warnings::warnif( 'deprecated',
        'verify() is deprecated; use called_ok() instead' );
    croak 'verify() must be given a mock object'
      if !MockType->check($mock);

    require Test::Mocha::Verify;
    return Test::Mocha::Verify->new( mock => $mock, %options );
}

## no critic (RequireArgUnpacking)
sub _get_called_ok_args {
    my $coderef = shift;
    my $test_name;
    $test_name = pop if ( @_ % 2 == 1 );
    my %options = @_;

    # set default option if none given
    $options{times} = 1 if keys %options == 0;

    croak 'You can set only one of these options: ' . join ', ',
      map { "'$_'" } keys %options
      unless keys %options == 1;

    ## no critic (ProhibitCascadingIfElse)
    if ( defined $options{times} ) {
        croak "'times' option must be a number"
          unless Num->check( $options{times} );
    }
    elsif ( defined $options{at_least} ) {
        croak "'at_least' option must be a number"
          unless Num->check( $options{at_least} );
    }
    elsif ( defined $options{at_most} ) {
        croak "'at_most' option must be a number"
          unless Num->check( $options{at_most} );
    }
    elsif ( defined $options{between} ) {
        croak "'between' option must be an arrayref "
          . 'with 2 numbers in ascending order'
          unless NumRange->check( $options{between} );
    }
    else {
        my ($option) = keys %options;
        croak "called_ok() was given an invalid option: '$option'";
    }
    $options{test_name} = $test_name if defined $test_name;

    return ( $coderef, %options );
}
## use critic

sub inspect (&) {
    my ($arg) = @_;

    $Test::Mocha::Mock::num_method_calls = 0;
    my $method_call = get_method_call($arg);
    my $mock        = $method_call->invocant;
    my $calls       = getattr( $mock, 'calls' );
    return grep { $method_call->satisfied_by($_) } @{$calls};
}

sub inspect_all ($) {
    my ($mock) = @_;

    croak 'inspect_all() must be given a mock object'
      if !MockType->check($mock);

    return @{ $mock->{calls} };
}

sub clear (@) {
    my @mocks = @_;

    ## no critic (ProhibitBooleanGrep)
    croak 'clear() must be given mock objects only'
      if !@mocks || grep { !MockType->check($_) } @mocks;
    ## use critic

    @{ getattr( $_, 'calls' ) } = () foreach @mocks;

    return;
}

## no critic (NamingConventions::Capitalization)
sub SlurpyArray () {
    # uncoverable pod
    return slurpy(ArrayRef);
}

sub SlurpyHash () {
    # uncoverable pod
    return slurpy(HashRef);
}
## use critic

sub class_mock {
    my ($mocked_class) = @_;

    my $module_file = join( q{/}, split q{::}, $mocked_class ) . '.pm';
    my $caller_pkg = caller;
    no strict 'refs';  ## no critic (TestingAndDebugging::ProhibitNoStrict)

    # make sure the real module is not already loaded
    croak "Package '$mocked_class' is already loaded so it cannot be mocked"
      if defined ${ $caller_pkg . '::INC' }{$module_file};

    # check if package has already been mocked
    croak "Package '$mocked_class' is already mocked"
      if defined *{ $mocked_class . '::AUTOLOAD' }{CODE};

    my $mock = mock($mocked_class);

    *{ $mocked_class . '::AUTOLOAD' } = sub {
        my ($method) = extract_method_name( our $AUTOLOAD );
        $mock->$method(@_);
    };
    return $mock;
}

1;

__END__