Commit | Line | Data |
0d863452 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't'; |
5 | @INC = '../lib'; |
6 | require './test.pl'; |
7 | } |
8 | use strict; |
9 | |
10 | use Tie::Array; |
11 | use Tie::Hash; |
12 | |
13 | # The feature mechanism is tested in t/lib/feature/smartmatch: |
14 | # This file tests the semantics of the operator, without worrying |
15 | # about feature issues such as scoping etc. |
16 | |
17 | # Predeclare vars used in the tests: |
18 | my $deep1 = []; push @$deep1, \$deep1; |
19 | my $deep2 = []; push @$deep2, \$deep2; |
20 | |
0d863452 |
21 | my @nums = (1..10); |
22 | tie my @tied_nums, 'Tie::StdArray'; |
23 | @tied_nums = (1..10); |
24 | |
25 | my %hash = (foo => 17, bar => 23); |
26 | tie my %tied_hash, 'Tie::StdHash'; |
27 | %tied_hash = %hash; |
28 | |
1cfb7049 |
29 | { |
30 | package Test::Object::NoOverload; |
31 | sub new { bless { key => 1 } } |
32 | } |
33 | |
34 | { |
35 | package Test::Object::CopyOverload; |
36 | sub new { bless { key => 1 } } |
37 | use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] }; |
38 | } |
39 | |
40 | { |
41 | package Test::Object::OverloadCodeRef; |
42 | sub new { bless $_[1] } |
43 | use overload '~~' => sub { shift->($_[1]) }; |
44 | } |
45 | |
46 | our $ov_obj = Test::Object::CopyOverload->new; |
47 | our $obj = Test::Object::NoOverload->new; |
48 | our $false_obj = Test::Object::OverloadCodeRef->new(sub { 0 }); |
49 | our $true_obj = Test::Object::OverloadCodeRef->new(sub { 1 }); |
50 | |
51 | |
0d863452 |
52 | # Load and run the tests |
53 | my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>; |
54 | plan tests => 2 * @tests; |
55 | |
56 | for my $test (@tests) { |
57 | my ($yn, $left, $right) = @$test; |
58 | |
59 | match_test($yn, $left, $right); |
60 | match_test($yn, $right, $left); |
61 | } |
62 | |
63 | sub match_test { |
64 | my ($yn, $left, $right) = @_; |
65 | |
66 | die "Bad test spec: ($yn, $left, $right)" |
a86f5011 |
67 | unless $yn eq "" || $yn eq "!" || $yn eq '@'; |
0d863452 |
68 | |
69 | my $tstr = "$left ~~ $right"; |
70 | |
71 | my $res; |
3e7dd34d |
72 | $res = eval $tstr // ""; #/ <- fix syntax colouring |
0d863452 |
73 | |
a86f5011 |
74 | chomp $@; |
75 | |
76 | if ( $yn eq '@' ) { |
77 | ok( $@ ne '', sprintf "%s%s: %s", $tstr, $@ ? ( ', $@', $@ ) : ( '', $res ) ); |
78 | } else { |
79 | if ( $@ ne '' ) { |
80 | fail("$tstr, \$\@: $@"); |
81 | } else { |
82 | ok( ($yn eq '!' xor $res), "$tstr: $res"); |
83 | } |
84 | } |
0d863452 |
85 | } |
86 | |
87 | |
88 | |
89 | sub foo {} |
90 | sub bar {2} |
1cfb7049 |
91 | sub gorch {2} |
92 | sub fatal {die "fatal sub\n"} |
0d863452 |
93 | |
1cfb7049 |
94 | sub a_const() {die "const\n" if @_; "a constant"} |
95 | sub b_const() {die "const\n" if @_; "a constant"} |
0d863452 |
96 | |
97 | __DATA__ |
1cfb7049 |
98 | # OBJECT |
99 | # - overloaded |
100 | $ov_obj "key" |
101 | $ov_obj {"key" => 1} |
102 | ! $ov_obj "foo" |
103 | ! $ov_obj \&foo |
104 | @ $ov_obj \&fatal |
105 | |
106 | # regular object |
107 | @ $obj "key" |
108 | @ $obj {"key" => 1} |
109 | @ $obj "foo" |
110 | @ $obj $obj |
111 | @ $obj sub { 1 } |
112 | @ $obj sub { 0 } |
113 | @ $obj \&foo |
114 | @ $obj \&fatal |
115 | |
0d863452 |
116 | # CODE ref against argument |
117 | # - arg is code ref |
118 | \&foo \&foo |
119 | ! \&foo sub {} |
120 | ! \&foo \&bar |
1cfb7049 |
121 | \&fatal \&fatal |
122 | ! \&foo \&fatal |
0d863452 |
123 | |
124 | # - arg is not code ref |
1cfb7049 |
125 | 1 sub{shift} |
126 | ! 0 sub{shift} |
127 | ! undef sub{shift} |
128 | undef sub{not shift} |
129 | 1 sub{scalar @_} |
130 | [] \&bar |
131 | {} \&bar |
132 | qr// \&bar |
133 | ! [] \&foo |
134 | ! {} \&foo |
135 | ! qr// \&foo |
136 | ! undef \&foo |
137 | undef \&bar |
138 | @ undef \&fatal |
139 | @ 1 \&fatal |
140 | @ [] \&fatal |
141 | @ "foo" \&fatal |
142 | @ qr// \&fatal |
143 | @ $obj \&bar |
144 | $ov_obj \&bar |
0d863452 |
145 | |
146 | # - null-prototyped subs |
147 | a_const "a constant" |
148 | a_const a_const |
149 | a_const b_const |
1cfb7049 |
150 | \&a_const \&a_const |
151 | ! \&a_const \&b_const |
152 | |
153 | # - non-null-prototyped subs |
154 | ! \&bar \&gorch |
155 | bar gorch |
156 | @ fatal bar |
0d863452 |
157 | |
158 | # HASH ref against: |
159 | # - another hash ref |
160 | {} {} |
161 | ! {} {1 => 2} |
162 | {1 => 2} {1 => 2} |
163 | {1 => 2} {1 => 3} |
164 | ! {1 => 2} {2 => 3} |
165 | \%main:: {map {$_ => 'x'} keys %main::} |
166 | |
167 | # - tied hash ref |
168 | \%hash \%tied_hash |
169 | \%tied_hash \%tied_hash |
170 | |
171 | # - an array ref |
172 | \%:: [keys %main::] |
173 | ! \%:: [] |
174 | {"" => 1} [undef] |
71b0fb34 |
175 | { foo => 1 } ["foo"] |
176 | { foo => 1 } ["foo", "bar"] |
177 | \%hash ["foo", "bar"] |
178 | \%hash ["foo"] |
179 | ! \%hash ["quux"] |
180 | \%hash [qw(foo quux)] |
0d863452 |
181 | |
182 | # - a regex |
183 | {foo => 1} qr/^(fo[ox])$/ |
184 | ! +{0..100} qr/[13579]$/ |
185 | |
186 | # - a string |
187 | +{foo => 1, bar => 2} "foo" |
188 | ! +{foo => 1, bar => 2} "baz" |
189 | |
190 | |
191 | # ARRAY ref against: |
192 | # - another array ref |
1cfb7049 |
193 | [] [] |
194 | ! [] [1] |
0d863452 |
195 | [["foo"], ["bar"]] [qr/o/, qr/a/] |
196 | ["foo", "bar"] [qr/o/, qr/a/] |
71b0fb34 |
197 | ! ["foo", "bar"] [qr/o/, "foo"] |
1cfb7049 |
198 | $deep1 $deep1 |
199 | ! $deep1 $deep2 |
0d863452 |
200 | |
1cfb7049 |
201 | \@nums \@tied_nums |
0d863452 |
202 | |
203 | # - a regex |
204 | [qw(foo bar baz quux)] qr/x/ |
205 | ! [qw(foo bar baz quux)] qr/y/ |
206 | |
207 | # - a number |
208 | [qw(1foo 2bar)] 2 |
209 | |
210 | # - a string |
211 | ! [qw(1foo 2bar)] "2" |
212 | |
213 | # Number against number |
214 | 2 2 |
215 | ! 2 3 |
216 | |
217 | # Number against string |
218 | 2 "2" |
219 | 2 "2.0" |
220 | ! 2 "2bananas" |
221 | ! 2_3 "2_3" |
222 | |
223 | # Regex against string |
224 | qr/x/ "x" |
225 | ! qr/y/ "x" |
226 | |
227 | # Regex against number |
228 | 12345 qr/3/ |
229 | |
230 | |
231 | # Test the implicit referencing |
232 | @nums 7 |
233 | @nums \@nums |
234 | ! @nums \\@nums |
235 | @nums [1..10] |
236 | ! @nums [0..9] |
237 | |
238 | %hash "foo" |
239 | %hash /bar/ |
71b0fb34 |
240 | %hash [qw(bar)] |
241 | ! %hash [qw(a b c)] |
242 | %hash %hash |
243 | %hash {%hash} |
244 | %hash %tied_hash |
245 | %tied_hash %tied_hash |
246 | %hash { foo => 5, bar => 10 } |
247 | ! %hash { foo => 5, bar => 10, quux => 15 } |
248 | |
249 | @nums { 1, '', 2, '' } |
250 | @nums { 1, '', 12, '' } |
251 | ! @nums { 11, '', 12, '' } |
b472f62a |
252 | |
253 | # UNDEF |
254 | ! 3 undef |
255 | ! 1 undef |
256 | ! [] undef |
257 | ! {} undef |
258 | ! \%::main undef |
259 | ! [1,2] undef |
260 | ! %hash undef |
261 | ! @nums undef |
262 | ! "foo" undef |
263 | ! "" undef |
264 | ! !1 undef |
265 | ! \&foo undef |
266 | ! sub { } undef |