| File: | blib/lib/Test/Mocha/Method.pm |
| Coverage: | 97.6% |
| 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 | 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 | ||||||
| 21 | my $Dumper = Test::Mocha::PartialDump->new( objects => 0, stringify => 1 ); | ||||||
| 22 | |||||||
| 23 | sub 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 | |||||||
| 31 | sub name { | ||||||
| 32 | # uncoverable pod | ||||||
| 33 | 2812 | 0 | 4700 | return $_[0]->{name}; | |||
| 34 | } | ||||||
| 35 | |||||||
| 36 | sub args { | ||||||
| 37 | # uncoverable pod | ||||||
| 38 | 1450 1450 | 0 | 667 1635 | 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 | 462 | 0 | 4638 | my ($self) = @_; | |||
| 48 | 462 | 386 | 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 | 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 | |||||||
| 117 | sub _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 | |||||||
| 163 | 1; | ||||||