1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
=pod
=encoding utf-8
=head1 PURPOSE
Test that match::simple works.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2013-2014 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
use strict;
use warnings;
use Test::More;
use Test::Fatal;
use match::simple;
diag(sprintf('implementation: %s', match::simple::IMPLEMENTATION));
my $obj = do {
package Local::SomeClass;
use overload q[""] => sub { q(XXX) }, fallback => 1;
bless [];
};
sub does_match {
my ($a, $b, $name) = @_;
my ($as, $bs) = map do {
no if ($] >= 5.010001), 'overloading';
ref($_) ? qq[$_] : defined($_) ? qq["$_"] : q[undef];
}, @_;
$name ||= "$as matches $bs";
ok(
$a |M| $b,
$name,
);
}
sub doesnt_match {
my ($a, $b, $name) = @_;
my ($as, $bs) = map do {
no if ($] >= 5.010001), 'overloading';
ref($_) ? qq[$_] : defined($_) ? qq["$_"] : q[undef];
}, @_;
$name ||= "$as NOT matches $bs";
ok(
!($a |M| $b),
$name,
);
}
# If the right hand side is "undef", then there is only a match if
# the left hand side is also "undef".
does_match(undef, undef);
doesnt_match($_, undef)
for 0, 1, q(), q(XXX), [], {}, sub {}, $obj;
# If the right hand side is a non-reference, then the match is a
# simple string match.
does_match(q(xxx), q(xxx));
doesnt_match($_, q(xxx))
for 0, 1, q(), q(XXX), [], {}, sub {}, $obj;
# If the right hand side is a reference to a regexp, then the left
# hand is evaluated.
does_match(q(xxx), qr(xxx), 'q(xxx) |M| qr(xxx)');
does_match(q(wwwxxxyyyzzz), qr(xxx), 'q(wwwxxxyyyzzz) |M| qr(xxx)');
doesnt_match($_, qr(xxx))
for 0, 1, q(), q(XXX), [], {}, sub {}, $obj;
doesnt_match(qr(xxx), q(xxx));
# If the right hand side is a code reference, then it is called in a
# boolean context with the left hand side being passed as an
# argument.
does_match(1, sub {$_});
doesnt_match(0, sub {$_});
does_match(1, sub {$_[0]});
doesnt_match(0, sub {$_[0]});
does_match(1, sub {1});
does_match(0, sub {1});
# If the right hand side is an object which provides a "MATCH"
# method, then it this is called as a method, with the left hand side
# being passed as an argument.
my $obj2 = do {
package Local::SomeOtherClass;
sub MATCH { $_[1] }
bless [];
};
does_match(1, $obj2);
doesnt_match(0, $obj2);
# If the right hand side is an object which overloads "~~", then a
# true smart match is performed.
if ($] >= 5.010001 and $] < 5.020000)
{
my $obj3 = eval q{
no warnings;
package Local::YetAnotherClass;
use overload q[~~] => sub { $_[1] };
bless [];
};
does_match(1, $obj3);
doesnt_match(0, $obj3);
}
# If the right hand side is an arrayref, then the operator recurses
# into the array, with the match succeeding if the left hand side
# matches any array element.
does_match(q(x), [qw(x y z)], 'q(x) |M| [qw(x y z)]');
# If any other value appears on the right hand side, the operator
# will croak.
ok(
exception { "Foo" |M| { foo => 1 } },
q(Matching against a regexp throws an exception.),
);
ok(
exception { "Foo" |M| \*STDOUT },
q(Matching against a filehandle throws an exception.),
);
done_testing;
|
