File Coverage

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

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
4088
11
212
use strict;
5
12
12
12
22
12
143
use warnings;
6
7# smartmatch dependencies
8
12
12
12
135
23
209
use 5.010001;
9
12
12
12
3971
4618
36
use experimental 'smartmatch';
10
11
12
12
12
399
84
305
use Carp 'croak';
12
12
12
12
27
8
278
use Scalar::Util qw( blessed looks_like_number refaddr );
13
12
12
12
4428
17
224
use Test::Mocha::PartialDump;
14
12
12
12
4294
24
80
use Test::Mocha::Types qw( Matcher Slurpy );
15
12
12
12
7961
14
398
use Test::Mocha::Util 'check_slurpy_arg';
16
12
12
12
32
9
25
use Types::Standard qw( ArrayRef HashRef Str );
17
18
12
12
12
3334
11
3884
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
345
0
468
    my ( $class, %args ) = @_;
26    ### assert: Str->check( $args{name} )
27    ### assert: ArrayRef->check( $args{args} )
28
345
721
    return bless \%args, $class;
29}
30
31sub name {
32    # uncoverable pod
33
1406
0
2335
    return $_[0]->{name};
34}
35
36sub args {
37    # uncoverable pod
38
725
725
0
327
794
    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
231
0
2382
    my ($self) = @_;
48
231
183
    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
469
231
    my ( $self, $invocation ) = @_;
57
58
469
378
    return unless $invocation->name eq $self->name;
59
60
247
254
    my @expected = $self->args;
61
247
208
    my @input    = $invocation->args;
62    # invocation arguments can't be argument matchers
63    ### assert: ! grep { Matcher->check($_) } @input
64
247
279
    check_slurpy_arg(@expected);
65
66    # match @input against @expected which may include argument matchers
67
247
526
    while ( @input && @expected ) {
68
214
257
        my $matcher = shift @expected;
69
70        # slurpy argument matcher
71
214
212
        if ( Slurpy->check($matcher) ) {
72
38
342
            $matcher = $matcher->{slurpy};
73            ### assert: $matcher->is_a_type_of(ArrayRef) || $matcher->is_a_type_of(HashRef)
74
75
38
16
            my $value;
76
38
37
            if ( $matcher->is_a_type_of(ArrayRef) ) {
77
18
876
                $value = [@input];
78            }
79            elsif ( $matcher->is_a_type_of(HashRef) ) {
80
20
8579
                return unless scalar(@input) % 2 == 0;
81
8
12
                $value = {@input};
82            }
83            # else { invalid matcher type }
84
26
51
            return unless $matcher->check($value);
85
86
21
109
            @input = ();
87        }
88        # argument matcher
89        elsif ( Matcher->check($matcher) ) {
90
70
7147
            return unless $matcher->check( shift @input );
91        }
92        # literal match
93        else {
94
106
956
            return unless _match( shift(@input), $matcher );
95        }
96    }
97
98    # slurpy matcher should handle empty argument lists
99
169
6784
    if ( @expected > 0 && Slurpy->check( $expected[0] ) ) {
100
6
62
        my $matcher = shift(@expected)->{slurpy};
101
102
6
3
        my $value;
103
6
8
        if ( $matcher->is_a_type_of(ArrayRef) ) {
104
4
106
            $value = [@input];
105        }
106        elsif ( $matcher->is_a_type_of(HashRef) ) {
107
2
523
            return unless scalar(@input) % 2 == 0;
108
2
3
            $value = {@input};
109        }
110        # else { invalid matcher type }
111
6
11
        return unless $matcher->check($value);
112    }
113
114
169
603
    return @input == 0 && @expected == 0;
115}
116
117sub _match {
118    # """Match 2 values for equality."""
119    # uncoverable pod
120
128
63
    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
128
181
    return if ref $x ne ref $y;
127
128    # objects match only if they are the same object
129
105
230
    if ( blessed($x) || ref($x) eq 'CODE' ) {
130
15
56
        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
90
83
    if ( ref($x) eq 'ARRAY' ) {
136
7
7
7
3
5
13
        return if $#{$x} != $#{$y};
137
138        # recurse to handle nested structures
139
6
6
4
8
        foreach ( 0 .. $#{$x} ) {
140
17
20
            return if !_match( $x->[$_], $y->[$_] );
141        }
142
4
11
        return 1;
143    }
144
145
83
75
    if ( ref($x) eq 'HASH' ) {
146        # smartmatch only matches the hash keys
147
4
10
        return if not $x ~~ $y;
148
149        # ... but we want to match the hash values too
150
3
3
2
4
        foreach ( keys %{$x} ) {
151
5
6
            return if !_match( $x->{$_}, $y->{$_} );
152        }
153
2
4
        return 1;
154    }
155
156    # avoid smartmatch doing number matches on strings
157    # e.g. '5x' ~~ 5 is true
158
79
213
    return if looks_like_number($x) xor looks_like_number($y);
159
160
75
233
    return $x ~~ $y;
161}
162
1631;