The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Test::EasyMock::Expectation;
use strict;
use warnings;

=head1 NAME

Test::EasyMock::Expectation - A expected behavior object.

=cut
use Carp qw(croak);
use Scalar::Util qw(refaddr);
use Test::More; # use eq_array.

=head1 CONSTRUCTORS

=head2 new({mock=>$mock, method=>$method, args=>$args})

Create a instance.

=cut
sub new {
    my ($class, $args) = @_;
    return bless {
        _mock => $args->{mock},
        _method => $args->{method},
        _args => $args->{args},
        _results => [ { code => sub { return; }, implicit => 1 } ],
    }, $class;
}

=head1 PROPERTIES

=head2 mock - A related mock object.

=cut
sub mock {
    my ($self) = @_;
    return $self->{_mock};
}

=head1 METHODS

=head2 push_result($code)

Add a method result behavior.

=cut
sub push_result {
    my ($self, $code) = @_;
    $self->remove_implicit_result();
    push @{$self->{_results}}, { code => $code };
}

=head2 set_stub_result($code)

Set a method result behavior as stub.

=cut
sub set_stub_result {
    my ($self, $code) = @_;
    $self->remove_implicit_result();
    $self->{_stub_result} = { code => $code };
}

=head2 remove_implicit_result()

Remove results which flagged with 'implicit'.

=cut
sub remove_implicit_result {
    my ($self) = @_;
    $self->{_results} = [
        grep { !$_->{implicit} } @{$self->{_results}}
    ];
}

=head2 retrieve_result()

Retrieve a result value.

=cut
sub retrieve_result {
    my ($self) = @_;
    my $result = shift @{$self->{_results}} || $self->{_stub_result};
    croak('no result.') unless $result;
    return $result->{code}->();
}

=head2 has_result

It is tested whether it has a result.

=cut
sub has_result {
    my ($self) = @_;
    return @{$self->{_results}} > 0;
}

=head2 has_stub_result

It is tested whether it has a stub result.

=cut
sub has_stub_result {
    my ($self) = @_;
    return exists $self->{_stub_result};
}

=head2 matches($args)

It is tested whether the specified argument matches.

=cut
sub matches {
    my ($self, $args) = @_;
    return refaddr($self->{_mock}) == refaddr($args->{mock})
        && $self->{_method} eq $args->{method}
        && eq_array($self->{_args}, $args->{args});
}

=head2 is_satisfied()

The call to expect tests whether it was called briefly.

=cut
sub is_satisfied {
    my ($self) = @_;
    return !$self->has_result;
}

=head2 unsatisfied_message()

The message showing a lacking call is acquired.

=cut
sub unsatisfied_message {
    my ($self) = @_;
    return sprintf(
        '%d calls of the `%s` method expected exist.',
        scalar(@{$self->{_results}}),
        $self->{_method}
    ) if $self->has_result;

    return;
}

1;