File Coverage

blib/lib/Test/CallFlow/Plan.pm

Criterion	Covered	Total	%
statement	108	108	100.0
branch	57	76	75.0
condition	16	24	66.6
subroutine	10	10	100.0
pod	7	7	100.0
total	198	225	88.0

package Test::CallFlow::Plan;
use strict;
use Carp;

=head1 Test::CallFlow::Plan

Contains planned calls to mocked functions.

=head1 METHODS

=head2 new

  my $mock_call_plan = Test::CallFlow::Plan->new( %properties );

=cut

sub new {
    my $class = shift;
    my $self = bless {@_}, $class;
    $self->reset;
    $self;
}

=head2 add_call

  $mock_call_plan->add_call( Test::CallFlow::Call->new( 'subname', @args ) );

Adds a call into this plan.

=cut

sub add_call {
    my ( $self, $call ) = @_;
    push @{ $self->{calls} ||= [] }, $call;
}

=head2 call

  $mock_call_plan->call( 'subname', @args );

Heart of plan execution. Searches for a matching call and returns the result.

This should be shortened for ease of further development. Then again, it seems to work.

=cut

sub call {
    my ( $self, $sub, @args ) = @_;
    warn "Plan got call $sub(@args) for planned call #$self->{at}\n"
        if $self->{debug};
    my $got_args = [ $sub, @args ];

    my ( @error, @errors );
    my $at = 0;
    my $call;
    my @try_calls;
    my $trying_in_order = 1;
    my @try_call_at = ( $self->{at} || 0 );
    my @unordered;
    my $num_calls = @{ $self->{calls} || [] };
    my $first_in_order_at;

    while (@try_call_at) {
        warn "Calls to try: @try_call_at",
            $trying_in_order ? "; delayed: @unordered" : ''
            if $self->{debug};
        $at   = shift @try_call_at;
        $call = $self->{calls}[$at]
            or last;

        if ( $trying_in_order and not $call->in_order ) {

            # try again later if match not found in order
            push @unordered, $at
                unless $at <= ( $self->{latest_unordered_at} || -1 );
            if ( ++$at < $num_calls ) {

                # try next in order
                unshift @try_call_at, $at;
            } else {

                # start going through unordered ones
                $trying_in_order = 0;
                @try_call_at = ( @{ $self->{anytime} || [] }, @unordered );
            }
            next;
        } elsif (     not defined $first_in_order_at
                  and not $call->over )
        {
            $first_in_order_at = $at;
        }

        last    # matched!
            unless @error = $call->check($got_args);

        push @errors, [ $at, @error ];

        if ($trying_in_order) {
            if ( $call->satisfied and ++$at < $num_calls ) {

                # this plan may be passed;
                # keep looking ahead in order
                unshift @try_call_at, $at;
                next;
            } else {

                # this plan must be matched in order before any later ones;
                # fallback to looking at unordered ones
                $trying_in_order = 0;
                @try_call_at = ( @{ $self->{anytime} || [] }, @unordered );
            }
        }
    }

    $self->failed_call( [ $sub, @args ], $self->{calls}, \@errors )
        if @error;

    croak "Unplanned call to mock at $self->{at}: $sub(@args)"
        unless $call;

    if (@unordered) {
        push @{ $self->{anytime} ||= [] }, @unordered;
        $self->{latest_unordered_at} = $unordered[-1];
    }

    if ( my $end_calls = $call->{end} ) {
        warn "end calls: @$end_calls" if $self->{debug};
        my %end_calls = map {
            croak(
"Expected call $_->{sub}(@{$_->{args}}) not made until end of scope\n"
            ) unless $_->satisfied;
            $_ => 1
        } @$end_calls;
        $self->{anytime} =
            [ grep { !$end_calls{$_} } @{ $self->{anytime} || [] } ];
    }

    my $result = $call->call;
    $result = wantarray ? ( $result->(@_) ) : ( scalar $result->(@_) )
        if ref $result eq 'CODE';
    $result = [] unless defined $result;
    $result = [$result] unless ref $result eq 'ARRAY';

    # point to where to start looking at next time
    warn "Going from ", ( $self->{at} || 0 ), " to $first_in_order_at"
        if $self->{debug};
    $self->{at} = $first_in_order_at;

    # skip those we can't use anymore
    while ( $self->{at} < $num_calls ) {
        my $call = $self->{calls}[ $self->{at} ];
        confess("Bad item in call plan at $self->{at} ($call)")
            unless ref $call;
        last unless $call->over;
        warn "Passing completed call #$self->{at} ($call->{called}/",
            $call->min, "-", $call->max, "): ", $call->name
            if $self->{debug};
        ++$self->{at};
    }

    warn "mock #$at $sub(@args) -> (@$result)" if $self->{debug};
    return wantarray ? @$result : $result->[0];
}

=head2 failed_call

  $mock_call_plan->failed_call( $called, $calls, \@errors );

Used by C to report errors. Croaks with a list of tried and failed call proposals.

=cut

sub failed_call {
    my ( $self, $called, $calls, $errors ) = @_;
    my $msg = '';
    my $at  = -1;
    while ( ++$at < @$errors ) {
        my ( $call_at, $arg_at, $test_at ) = @{ $errors->[$at] };
        my $call = $self->{calls}[$call_at];
        $msg .=
              $arg_at
            ? $test_at < @{ $call->{args} }
                ? "Call '$called->[0]' argument #$arg_at ($called->[$arg_at]) did not match "
                : "Too many arguments (" . ( @$called - 1 ) . ") after last "
            : "Called sub name '$called->[0]' did not match ";
        $msg .=
            $test_at
            ? "argument test #$test_at"
            : "sub name";
        $msg .= " of "
            . (   $call->in_order
                ? $call->min
                        ? 'required'
                        : 'optional'
                : 'unordered' );
        $msg .= " planned call " . $call->name . "\n";
    }

    croak($msg);
}

=head2 unsatisfied

Returns an array of remaining unsatisfied calls.

Whole plan can be seen as successfully executed once this returns an empty array.

=cut

sub unsatisfied {
    my $self      = shift;
    my $last_call = @{ $self->{calls} } - 1;

    grep { !$_->satisfied }
        $self->{calls}[ ( $self->{at} || 0 ), $last_call ],
        map { $self->{calls}[$_] } @{ $self->{anytime} || [] };
}

=head2 reset

  $plan->reset;

Return to planning state, preserving all previously made plans and discarding any results of running.

=cut

sub reset {
    my $self = shift;
    warn "Reset Mock Plan at ", ( $self->{at} || 0 )
        if $self->{debug};
    $_->reset for @{ $self->{calls} };
    $self->_clean;
}

sub _clean {
    my $self = shift;
    delete $self->{at};
    delete $self->{anytime};
    delete $self->{latest_unordered_at};
}

=head2 list_calls

Returns the list of calls in this plan.

=cut

sub list_calls {
    my $self = shift;
    @{ $self->{calls} };
}

1;