File Coverage

File:blib/lib/Test/Mocha/Method.pm
Coverage:97.7%

linestmtbrancondsubpodtimecode
1package Test::Mocha::Method;
2# ABSTRACT: Objects to represent methods and their arguuments
3$Test::Mocha::Method::VERSION = '0.61';
4
12
12
12
4378
12
254
use strict;
5
12
12
12
24
13
157
use warnings;
6
7# smartmatch dependencies
8
12
12
12
136
22
261
use 5.010001;
9
12
12
12
4018
5099
38
use experimental 'smartmatch';
10
11
12
12
12
432
10
342
use Carp 'croak';
12
12
12
12
47
12
350
use Scalar::Util qw( blessed looks_like_number refaddr );
13
12
12
12
4915
21
253
use Test::Mocha::PartialDump;
14
12
12
12
4719
27
89
use Test::Mocha::Types qw( Matcher Slurpy );
15
12
12
12
9100
17
471
use Test::Mocha::Util 'check_slurpy_arg';
16
12
12
12
40
12
33
use Types::Standard qw( ArrayRef HashRef Str );
17
18
12
12
12
4088
13
4635
use overload '""' => \&stringify, fallback => 1;
19
20# cause string overloaded objects (Matchers) to be stringified
21my $Dumper = Test::Mocha::PartialDump->new( objects => 0, stringify => 1 );
22
23sub new {
24    # uncoverable pod
25
314
0
452
    my ( $class, %args ) = @_;
26    ### assert: Str->check( $args{name} )
27    ### assert: ArrayRef->check( $args{args} )
28
314
706
    return bless \%args, $class;
29}
30
31sub name {
32    # uncoverable pod
33
1572
0
2688
    return $_[0]->{name};
34}
35
36sub args {
37    # uncoverable pod
38
727
727
0
316
758
    return @{ $_[0]->{args} };
39}
40
41sub stringify {
42    # """
43    # Stringifies this method call to something that roughly resembles what
44    # you'd type in Perl.
45    # """
46    # uncoverable pod
47
113
0
1987
    my ($self) = @_;
48
113
110
    return $self->name . '(' . $Dumper->dump( $self->args ) . ')';
49}
50
51sub satisfied_by {
52    # """
53    # Returns true if the given C<$invocation> satisfies this method call.
54    # """
55    # uncoverable pod
56
529
0
287
    my ( $self, $invocation ) = @_;
57
58
529
369
    return unless $invocation->name eq $self->name;
59
60
307
334
    my @expected = $self->args;
61
307
286
    my @input    = $invocation->args;
62    # invocation arguments can't be argument matchers
63    ### assert: ! grep { Matcher->check($_) } @input
64
307
331
    check_slurpy_arg(@expected);
65
66    # match @input against @expected which may include argument matchers
67
307
630
    while ( @input && @expected ) {
68
274
233
        my $matcher = shift @expected;
69
70        # slurpy argument matcher
71
274
256
        if ( Slurpy->check($matcher) ) {
72
43
386
            $matcher = $matcher->{slurpy};
73            ### assert: $matcher->is_a_type_of(ArrayRef) || $matcher->is_a_type_of(HashRef)
74
75
43
18
            my $value;
76
43
41
            if ( $matcher->is_a_type_of(ArrayRef) ) {
77
23
994
                $value = [@input];
78            }
79            elsif ( $matcher->is_a_type_of(HashRef) ) {
80
20
8592
                return unless scalar(@input) % 2 == 0;
81
8
15
                $value = {@input};
82            }
83            # else { invalid matcher type }
84
31
62
            return unless $matcher->check($value);
85
86
26
128
            @input = ();
87        }
88        # argument matcher
89        elsif ( Matcher->check($matcher) ) {
90
82
7770
            return unless $matcher->check( shift @input );
91        }
92        # literal match
93        else {
94
149
1278
            return unless __match( shift(@input), $matcher );
95        }
96    }
97
98    # slurpy matcher should handle empty argument lists
99
193
7371
    if ( @expected > 0 && Slurpy->check( $expected[0] ) ) {
100
6
63
        my $matcher = shift(@expected)->{slurpy};
101
102
6
7
        my $value;
103
6
6
        if ( $matcher->is_a_type_of(ArrayRef) ) {
104
4
116
            $value = [@input];
105        }
106        elsif ( $matcher->is_a_type_of(HashRef) ) {
107
2
519
            return unless scalar(@input) % 2 == 0;
108
2
2
            $value = {@input};
109        }
110        # else { invalid matcher type }
111
6
11
        return unless $matcher->check($value);
112    }
113
114
193
753
    return @input == 0 && @expected == 0;
115}
116
117sub __match {
118    # """Match 2 values for equality."""
119    # uncoverable pod
120
171
115
    my ( $x, $y ) = @_;
121
122    # This function uses smart matching, but we need to limit the scenarios
123    # in which it is used because of its quirks.
124
125    # ref types must match
126
171
220
    return if ref $x ne ref $y;
127
128    # objects match only if they are the same object
129
148
328
    if ( blessed($x) || ref($x) eq 'CODE' ) {
130
16
63
        return refaddr($x) == refaddr($y);
131    }
132
133    # don't smartmatch on arrays because it recurses
134    # which leads to the same quirks that we want to avoid
135
132
120
    if ( ref($x) eq 'ARRAY' ) {
136
7
7
7
3
7
11
        return if $#{$x} != $#{$y};
137
138        # recurse to handle nested structures
139
6
6
5
9
        foreach ( 0 .. $#{$x} ) {
140
17
21
            return if !__match( $x->[$_], $y->[$_] );
141        }
142
4
15
        return 1;
143    }
144
145
125
108
    if ( ref($x) eq 'HASH' ) {
146        # smartmatch only matches the hash keys
147
4
11
        return if not $x ~~ $y;
148
149        # ... but we want to match the hash values too
150
3
3
2
5
        foreach ( keys %{$x} ) {
151
5
6
            return if !__match( $x->{$_}, $y->{$_} );
152        }
153
2
11
        return 1;
154    }
155
156    # avoid smartmatch doing number matches on strings
157    # e.g. '5x' ~~ 5 is true
158
121
342
    return if looks_like_number($x) xor looks_like_number($y);
159
160
110
318
    return $x ~~ $y;
161}
162
1631;