File Coverage

blib/lib/Test/ExpectAndCheck.pm

Criterion	Covered	Total	%
statement	121	134	90.3
branch	28	36	77.7
condition	4	6	66.6
subroutine	28	30	93.3
pod	3	3	100.0
total	184	209	88.0

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2021 -- [e-mail]

package Test::ExpectAndCheck;

use strict;
use warnings;

our $VERSION = '0.04';

use Carp;

use List::Util qw( first );
use Scalar::Util qw( blessed );

use Test::Deep ();

use constant EXPECTATION_CLASS => "Test::ExpectAndCheck::_Expectation";

=head1 NAME

C - C-style unit testing with object methods

=head1 SYNOPSIS

   use Test::More;
   use Test::ExpectAndCheck;

   my ( $controller, $mock ) = Test::ExpectAndCheck->create;

   {
      $controller->expect( act => 123, 45 )
         ->will_return( 678 );

      is( $mock->act( 123, 45 ), 678, '$mock->act returns result' );

      $controller->check_and_clear( '->act' );
   }

   done_testing;

=head1 DESCRIPTION

This package creates objects that assist in writing unit tests with mocked
object instances. Each mock instance will expect to receive a given list of
method calls. Each method call is checked that it received the right
arguments, and will return a prescribed result. At the end of each test, each
object is checked to ensure all the expected methods were called.

=cut

=head1 METHODS

=cut

=head2 create

   ( $controller, $mock ) = Test::ExpectAndCheck->create;

Objects are created in "entangled pairs" by the C method. The first
object is called the "controller", and is used by the unit testing script to
set up what method calls are to be expected, and what their results shall be.
The second object is the "mock", the object to be passed to the code being
tested, on which the expected method calls are (hopefully) invoked. It will
have whatever interface is implied by the method call expectations.

=cut

sub create
{
   my $class = shift;

   my $controller = bless {
      expectations => [],
   }, $class;
   my $mock = Test::ExpectAndCheck::_Obj->new( $controller );

   return ( $controller, $mock );
}

=head2 expect

   $exp = $controller->expect( $method, @args )

Specifies that the mock will expect to receive a method call of the given
name, with the given arguments.

The argument values are compared using L. Values can
be specified literally, or using any of the "Special Comparisons" defined by
L.

The test script can call the L or L methods on the
expectation to set what the result of invoking this method will be.

=cut

sub expect
{
   my $self = shift;
   my ( $method, @args ) = @_;

   my ( undef, $file, $line ) = caller(1);
   defined $file or ( undef, $file, $line ) = caller(0);

   push @{ $self->{expectations} }, my $exp = $self->EXPECTATION_CLASS->new(
      $method => [ @args ], $file, $line,
   );

   return $exp;
}

sub _stringify
{
   my ( $v ) = @_;
   if( !defined $v ) {
      return "undef";
   }
   elsif( blessed $v and $v->isa( "Test::Deep::Ignore" ) ) {
      return "ignore()";
   }
   elsif( $v =~ m/^-?[0-9]+$/ ) {
      return sprintf "%d", $v;
   }
   elsif( $v =~ m/^[\x20-\x7E]*\z/ ) {
      $v =~ s/([\\'])/\\$1/g;
      return qq('$v');
   }
   else {
      if( $v =~ m/[^\n\x20-\x7E]/ ) {
         # string contains something non-printable; just hexdump it all
         $v =~ s{(.)}{sprintf "\\x%02X", ord $1}gse;
      }
      else {
         $v =~ s/([\\'\$\@])/\\$1/g;
         $v =~ s{\n}{\\n}g;
      }
      return qq("$v");
   }
}

sub _stringify_args
{
   join ", ", map { _stringify $_ } @_;
}

sub _call
{
   my $self = shift;
   my ( $method, @args ) = @_;

   my $e;
   $e = first { !$_->_called } @{ $self->{expectations} } and
      $e->_consume( $method, @args ) or do {
         my $message = Carp::shortmess( "Unexpected call to ->$method(${\ _stringify_args @args })" );
         $message .= "... while expecting " . $e->_stringify if $e;
         $message .= "... after all expectations done" if !$e;
         die "$message.\n";
      };

   return $e->_result;
}

=head2 check_and_clear

   $controller->check_and_clear( $name );

Checks that by now, every expected method has been called, and emits a new
test output line via L. Regardless, the expectations are also
cleared out ready for the start of the next test.

=cut

sub check_and_clear
{
   my $self = shift;
   my ( $name ) = @_;

   my $builder = Test::Builder->new;
   local $Test::Builder::Level = $Test::Builder::Level + 1;

   $builder->subtest( $name, sub {
      my $count = 0;
      foreach my $exp ( @{ $self->{expectations} } ) {
         $exp->_check( $builder );
         $count++;
      }

      $builder->ok( 1, "No calls made" ) if !$count;
   });

   undef @{ $self->{expectations} };
}

package
   Test::ExpectAndCheck::_Expectation;

use List::Util qw( all );

use constant {
   METHOD  => 0,
   ARGS    => 1,
   FILE    => 2,
   LINE    => 3,
   CALLED  => 4,
   RETURNS => 5,
   THROWS  => 6,
   DIAG    => 7,
   ALSO    => 8,
};

=head1 EXPECTATIONS

Each value returned by the L method is an "expectation", an object
that represents one expected method call, the arguments it should receive, and
the return value it should provide.

=cut

sub new
{
   my $class = shift;
   my ( $method, $args, $file, $line ) = @_;
   return bless [ $method, $args, $file, $line, 0 ], $class;
}

=head2 will_return

   $exp->will_return( @result );

I

Sets the result that will be returned by this method call.

This method used to be named C, which should be avoided in new code.
Uses of the old name will print a deprecation warning.

=cut

sub will_return
{
   my $self = shift;

   $self->[RETURNS] = [ @_ ];
   undef $self->[THROWS];

   return $self;
}

sub returns
{
   warnings::warnif deprecated => "Calling \$exp->returns() is now deprecated; use ->will_return instead";
   return shift->will_return( @_ );
}

=head2 will_throw

   $exp->will_throw( $e );

I

Sets the exception that will be thrown by this method call.

This method used to be named C, which should be avoided in new code.

=cut

sub will_throw
{
   my $self = shift;
   ( $self->[THROWS] ) = @_;

   return $self;
}

sub throws
{
   warnings::warnif deprecated => "Calling \$exp->throws() is now deprecated; use ->will_throw instead";
   return shift->will_throw( @_ );
}

=head2 will_also

   $exp->will_also( sub { ... } );

I

Adds extra code which is run when the expected method is called, in addition
to generating the result value or exception.

When invoked, the code body is invoked in void context with no additional
arguments.

=cut

sub will_also
{
   my $self = shift;
   push @{ $self->[ALSO] }, @_;

   return $self;
}

sub _consume
{
   my $self = shift;
   my ( $method, @args ) = @_;

   $method eq $self->[METHOD] or
      return 0;

   my ( $ok, $stack ) = Test::Deep::cmp_details( \@args, $self->[ARGS] );
   unless( $ok ) {
      $self->[DIAG] = Test::Deep::deep_diag( $stack );
      return 0;
   }

   $self->[CALLED]++;
   return 1;
}

sub _check
{
   my $self = shift;
   my ( $builder ) = @_;

   my $method = $self->[METHOD];
   $builder->ok( $self->[CALLED], "->$method(${\ Test::ExpectAndCheck::_stringify_args @{ $self->[ARGS] } })" );
   $builder->diag( $self->[DIAG] ) if defined $self->[DIAG];
}

sub _result
{
   my $self = shift;

   if( my $also = $self->[ALSO] ) {
      $_->() for @$also;
   }

   die $self->[THROWS] if defined $self->[THROWS];
   return unless $self->[RETURNS];
   return @{ $self->[RETURNS] } if wantarray;
   return $self->[RETURNS][0];
}

sub _called
{
   my $self = shift;
   return $self->[CALLED];
}

sub _stringify
{
   my $self = shift;
   return "->$self->[METHOD](${\( Test::ExpectAndCheck::_stringify_args @{ $self->[ARGS] } )}) at $self->[FILE] line $self->[LINE]";
}

package
   Test::ExpectAndCheck::_Obj;

our @CARP_NOT = qw( Test::ExpectAndCheck );

sub new
{
   my $class = shift;
   my ( $controller ) = @_;

   return bless [ $controller ], $class;
}

sub AUTOLOAD
{
   my $self = shift;
   ( our $AUTOLOAD ) =~ m/::([^:]+)$/;
   my $method = $1;

   return if $method eq "DESTROY";

   return $self->[0]->_call( $method, @_ );
}

=head1 AUTHOR

Paul Evans

=cut

0x55AA;