view release on metacpan or  search on metacpan

local/lib/perl5/Test/Spec/Mocks.pm  view on Meta::CPAN

package Test::Spec::Mocks;
use strict;
use warnings;
use Carp ();
use Scalar::Util ();
use Test::Deep::NoTest ();

require Test::Spec;

our @EXPORT_OK = qw(stubs stub expects mock);
our @EXPORT = @EXPORT_OK;

our $Debug = $ENV{TEST_SPEC_MOCKS_DEBUG};

our %To_Universal = map { $_ => 1 } qw(stubs expects);

#
# use Test::Spec::Mocks ();               # nothing (import never called)
# use Test::Spec::Mocks;                  # stubs,expects=>UNIVERSAL, stub,mock=>caller
# use Test::Spec::Mocks qw(stubs stub);   # stubs=>UNIVERSAL, stub=>caller
#
sub import {
  my $srcpkg = shift;
  my $callpkg = caller(0);
  my @syms = @_ ? @_ : @EXPORT;
  SYMBOL: for my $orig_sym (@syms) {
    no strict 'refs';
    # accept but ignore leading '&', we only export subs
    (my $sym = $orig_sym) =~ s{\A\&}{};
    if (not grep { $_ eq $sym } @EXPORT_OK) {
      Carp::croak("\"$orig_sym\" is not exported by the $srcpkg module");
    }
    my $destpkg = $To_Universal{$sym} ? 'UNIVERSAL' : $callpkg;
    my $src  = join("::", $srcpkg, $sym);
    my $dest = join("::", $destpkg, $sym);
    if (defined &$dest) {
      if (*{$dest}{CODE} == *{$src}{CODE}) {
        # already exported, ignore request
        next SYMBOL;
      }
      else {
        Carp::carp("Clobbering existing \"$orig_sym\" in package $destpkg");
      }
    }
    *$dest = \&$src;
  }
}

# Foo->stubs("name")                    # empty return value
# Foo->stubs("name" => "value")         # static return value
# Foo->stubs("name" => sub { "value" }) # dynamic return value

sub stubs {
  _install('Test::Spec::Mocks::Stub', @_);
}

# Foo->expects("name")                  # empty return value
sub expects {
  if (@_ != 2 || ref($_[1])) {
    Carp::croak "usage: ->expects('foo')";
  }
  _install('Test::Spec::Mocks::Expectation', @_);
}

sub _install {
  my $stub_class = shift;
  my ($caller) = ((caller(1))[3] =~ /.*::(.*)/);

  my $target = shift;
  my @methods;

  # normalize name/value pairs to name/subroutine pairs
  if (@_ > 0 && @_ % 2 == 0) {
    # list of name/value pairs
    while (my ($name,$value) = splice(@_,0,2)) {
      push @methods, { name => $name, value => $value };
    }
  }
  elsif (@_ == 1 && ref($_[0]) eq 'HASH') {
    # hash ref of name/value pairs
    my $args = shift;
    while (my ($name,$value) = each %$args) {
      push @methods, { name => $name, value => $value };
    }
  }
  elsif (@_ == 1 && !ref($_[0])) {
    # name only
    push @methods, { name => shift };
  }
  else {
    Carp::croak "usage: $caller('foo'), $caller(foo=>'bar') or $caller({foo=>'bar'})";
  }

  my $context = Test::Spec->current_context
    || Carp::croak "Test::Spec::Mocks only works in conjunction with Test::Spec";
  my $retval; # for chaining. last wins.

  for my $method (@methods) {
    my $stub = $stub_class->new({ target => $target, method => $method->{name} });
    $stub->returns($method->{value}) if exists $method->{value};
    $context->on_enter(sub { $stub->setup });
    $context->on_leave(sub { $stub->teardown });
    $retval = $stub;
  }

  return $retval;
}

# $stub_object = stub();
# $stub_object = stub(method => 'result');
# $stub_object = stub(method => sub { 'result' });
sub stub {
  my $args;
  if (@_ % 2 == 0) {
    $args = { @_ };
  }
  elsif (@_ == 1 && ref($_[0]) eq 'HASH') {
    $args = shift;
  }
  else {
    Carp::croak "usage: stub(%HASH) or stub(\\%HASH)";
  }
  my $blank = _make_mock();
  $blank->stubs($args) if @_;
  return $blank;
}

# $mock_object = mock(); $mock_object->expects(...)
sub mock {
  Carp::croak "usage: mock()" if @_;
  return _make_mock();
}

{
  package Test::Spec::Mocks::MockObject;
  # this page intentionally left blank
}

# keep this out of the MockObject class, so it has a blank slate
sub _make_mock {
  return bless({}, 'Test::Spec::Mocks::MockObject');
}

{
  package Test::Spec::Mocks::Expectation;

  sub new {
    my $class = shift;
    my $self = bless {}, $class;

    # expect to be called exactly one time in the default case