File: | blib/lib/Test/Mocha/Method.pm |
Coverage: | 97.7% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | package 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 | ||||||
21 | my $Dumper = Test::Mocha::PartialDump->new( objects => 0, stringify => 1 ); | ||||||
22 | |||||||
23 | sub 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 | |||||||
31 | sub name { | ||||||
32 | # uncoverable pod | ||||||
33 | 1572 | 0 | 2688 | return $_[0]->{name}; | |||
34 | } | ||||||
35 | |||||||
36 | sub args { | ||||||
37 | # uncoverable pod | ||||||
38 | 727 727 | 0 | 316 758 | return @{ $_[0]->{args} }; | |||
39 | } | ||||||
40 | |||||||
41 | sub 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 | |||||||
51 | sub 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 | |||||||
117 | sub __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 | |||||||
163 | 1; |