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
24
24
24
8626
20
474
use strict;
5
24
24
24
49
21
324
use warnings;
6
7# smartmatch dependencies
8
24
24
24
292
50
443
use 5.010001;
9
24
24
24
8423
9851
77
use experimental 'smartmatch';
10
11
24
24
24
841
182
732
use Carp 'croak';
12
24
24
24
63
18
673
use Scalar::Util qw( blessed looks_like_number refaddr );
13
24
24
24
9334
33
457
use Test::Mocha::PartialDump;
14
24
24
24
8795
47
165
use Test::Mocha::Types qw( Matcher Slurpy );
15
24
24
24
16461
32
844
use Test::Mocha::Util 'check_slurpy_arg';
16
24
24
24
69
20
50
use Types::Standard qw( ArrayRef HashRef Str );
17
18
24
24
24
6843
23
7925
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
690
0
988
    my ( $class, %args ) = @_;
26    ### assert: Str->check( $args{name} )
27    ### assert: ArrayRef->check( $args{args} )
28
690
1495
    return bless \%args, $class;
29}
30
31sub name {
32    # uncoverable pod
33
2812
0
4700
    return $_[0]->{name};
34}
35
36sub args {
37    # uncoverable pod
38
1450
1450
0
667
1635
    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
462
0
4638
    my ($self) = @_;
48
462
386
    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
938
510
    my ( $self, $invocation ) = @_;
57
58
938
717
    return unless $invocation->name eq $self->name;
59
60
494
536
    my @expected = $self->args;
61
494
419
    my @input    = $invocation->args;
62    # invocation arguments can't be argument matchers
63    ### assert: ! grep { Matcher->check($_) } @input
64
494
563
    check_slurpy_arg(@expected);
65
66    # match @input against @expected which may include argument matchers
67
494
1063
    while ( @input && @expected ) {
68
428
474
        my $matcher = shift @expected;
69
70        # slurpy argument matcher
71
428
447
        if ( Slurpy->check($matcher) ) {
72
76
705
            $matcher = $matcher->{slurpy};
73            ### assert: $matcher->is_a_type_of(ArrayRef) || $matcher->is_a_type_of(HashRef)
74
75
76
38
            my $value;
76
76
75
            if ( $matcher->is_a_type_of(ArrayRef) ) {
77
36
1936
                $value = [@input];
78            }
79            elsif ( $matcher->is_a_type_of(HashRef) ) {
80
40
17127
                return unless scalar(@input) % 2 == 0;
81
16
26
                $value = {@input};
82            }
83            # else { invalid matcher type }
84
52
104
            return unless $matcher->check($value);
85
86
42
219
            @input = ();
87        }
88        # argument matcher
89        elsif ( Matcher->check($matcher) ) {
90
140
15060
            return unless $matcher->check( shift @input );
91        }
92        # literal match
93        else {
94
212
1961
            return unless _match( shift(@input), $matcher );
95        }
96    }
97
98    # slurpy matcher should handle empty argument lists
99
338
13771
    if ( @expected > 0 && Slurpy->check( $expected[0] ) ) {
100
12
125
        my $matcher = shift(@expected)->{slurpy};
101
102
12
5
        my $value;
103
12
16
        if ( $matcher->is_a_type_of(ArrayRef) ) {
104
8
214
            $value = [@input];
105        }
106        elsif ( $matcher->is_a_type_of(HashRef) ) {
107
4
1046
            return unless scalar(@input) % 2 == 0;
108
4
4
            $value = {@input};
109        }
110        # else { invalid matcher type }
111
12
22
        return unless $matcher->check($value);
112    }
113
114
338
1263
    return @input == 0 && @expected == 0;
115}
116
117sub _match {
118    # """Match 2 values for equality."""
119    # uncoverable pod
120
256
143
    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
256
367
    return if ref $x ne ref $y;
127
128    # objects match only if they are the same object
129
210
488
    if ( blessed($x) || ref($x) eq 'CODE' ) {
130
30
111
        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
180
169
    if ( ref($x) eq 'ARRAY' ) {
136
14
14
14
8
8
26
        return if $#{$x} != $#{$y};
137
138        # recurse to handle nested structures
139
12
12
10
14
        foreach ( 0 .. $#{$x} ) {
140
34
41
            return if !_match( $x->[$_], $y->[$_] );
141        }
142
8
22
        return 1;
143    }
144
145
166
152
    if ( ref($x) eq 'HASH' ) {
146        # smartmatch only matches the hash keys
147
8
18
        return if not $x ~~ $y;
148
149        # ... but we want to match the hash values too
150
6
6
5
7
        foreach ( keys %{$x} ) {
151
10
11
            return if !_match( $x->{$_}, $y->{$_} );
152        }
153
4
8
        return 1;
154    }
155
156    # avoid smartmatch doing number matches on strings
157    # e.g. '5x' ~~ 5 is true
158
158
442
    return if looks_like_number($x) xor looks_like_number($y);
159
160
150
465
    return $x ~~ $y;
161}
162
1631;