Commit | Line | Data |
---|---|---|
0d863452 RH |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
7 | ||
8 | use strict; | |
9 | use warnings; | |
10 | ||
6e03d743 | 11 | use Test::More tests => 113; |
0d863452 RH |
12 | |
13 | # The behaviour of the feature pragma should be tested by lib/switch.t | |
14 | # using the tests in t/lib/switch/*. This file tests the behaviour of | |
15 | # the switch ops themselves. | |
16 | ||
17 | ||
18 | use feature 'switch'; | |
19 | no warnings "numeric"; | |
20 | ||
21 | eval { continue }; | |
22 | like($@, qr/^Can't "continue" outside/, "continue outside"); | |
23 | ||
24 | eval { break }; | |
25 | like($@, qr/^Can't "break" outside/, "break outside"); | |
26 | ||
27 | # Scoping rules | |
28 | ||
29 | { | |
30 | my $x = "foo"; | |
31 | given(my $x = "bar") { | |
32 | is($x, "bar", "given scope starts"); | |
33 | } | |
34 | is($x, "foo", "given scope ends"); | |
35 | } | |
36 | ||
37 | sub be_true {1} | |
38 | ||
39 | given(my $x = "foo") { | |
40 | when(be_true(my $x = "bar")) { | |
41 | is($x, "bar", "given scope starts"); | |
42 | } | |
43 | is($x, "foo", "given scope ends"); | |
44 | } | |
45 | ||
46 | $_ = "outside"; | |
47 | given("inside") { check_outside1() } | |
48 | sub check_outside1 { is($_, "outside", "\$_ lexically scoped") } | |
49 | ||
50 | { | |
51 | my $_ = "outside"; | |
52 | given("inside") { check_outside2() } | |
53 | sub check_outside2 { | |
54 | is($_, "outside", "\$_ lexically scoped (lexical \$_)") | |
55 | } | |
56 | } | |
57 | ||
58 | # Basic string/numeric comparisons and control flow | |
59 | ||
60 | { | |
cd9c531b | 61 | my $ok; |
0d863452 | 62 | given(3) { |
cd9c531b NC |
63 | when(2) { $ok = 'two'; } |
64 | when(3) { $ok = 'three'; } | |
65 | when(4) { $ok = 'four'; } | |
66 | default { $ok = 'd'; } | |
0d863452 | 67 | } |
cd9c531b | 68 | is($ok, 'three', "numeric comparison"); |
0d863452 RH |
69 | } |
70 | ||
71 | { | |
cd9c531b | 72 | my $ok; |
0d863452 RH |
73 | use integer; |
74 | given(3.14159265) { | |
cd9c531b NC |
75 | when(2) { $ok = 'two'; } |
76 | when(3) { $ok = 'three'; } | |
77 | when(4) { $ok = 'four'; } | |
78 | default { $ok = 'd'; } | |
0d863452 | 79 | } |
cd9c531b | 80 | is($ok, 'three', "integer comparison"); |
0d863452 RH |
81 | } |
82 | ||
83 | { | |
cd9c531b | 84 | my ($ok1, $ok2); |
0d863452 | 85 | given(3) { |
cd9c531b NC |
86 | when(3.1) { $ok1 = 'n'; } |
87 | when(3.0) { $ok1 = 'y'; continue } | |
88 | when("3.0") { $ok2 = 'y'; } | |
89 | default { $ok2 = 'n'; } | |
0d863452 | 90 | } |
cd9c531b NC |
91 | is($ok1, 'y', "more numeric (pt. 1)"); |
92 | is($ok2, 'y', "more numeric (pt. 2)"); | |
0d863452 RH |
93 | } |
94 | ||
95 | { | |
cd9c531b | 96 | my $ok; |
0d863452 | 97 | given("c") { |
cd9c531b NC |
98 | when("b") { $ok = 'B'; } |
99 | when("c") { $ok = 'C'; } | |
100 | when("d") { $ok = 'D'; } | |
101 | default { $ok = 'def'; } | |
0d863452 | 102 | } |
cd9c531b | 103 | is($ok, 'C', "string comparison"); |
0d863452 RH |
104 | } |
105 | ||
106 | { | |
cd9c531b | 107 | my $ok; |
0d863452 | 108 | given("c") { |
cd9c531b NC |
109 | when("b") { $ok = 'B'; } |
110 | when("c") { $ok = 'C'; continue } | |
111 | when("c") { $ok = 'CC'; } | |
112 | default { $ok = 'D'; } | |
0d863452 | 113 | } |
cd9c531b | 114 | is($ok, 'CC', "simple continue"); |
0d863452 RH |
115 | } |
116 | ||
117 | # Definedness | |
118 | { | |
119 | my $ok = 1; | |
120 | given (0) { when(undef) {$ok = 0} } | |
cd9c531b | 121 | is($ok, 1, "Given(0) when(undef)"); |
0d863452 RH |
122 | } |
123 | { | |
124 | my $undef; | |
125 | my $ok = 1; | |
126 | given (0) { when($undef) {$ok = 0} } | |
cd9c531b | 127 | is($ok, 1, 'Given(0) when($undef)'); |
0d863452 RH |
128 | } |
129 | { | |
130 | my $undef; | |
131 | my $ok = 0; | |
132 | given (0) { when($undef++) {$ok = 1} } | |
cd9c531b | 133 | is($ok, 1, "Given(0) when($undef++)"); |
0d863452 RH |
134 | } |
135 | { | |
62ec5f58 RGS |
136 | no warnings "uninitialized"; |
137 | my $ok = 0; | |
138 | given (undef) { when(0) {$ok = 1} } | |
cd9c531b | 139 | is($ok, 1, "Given(undef) when(0)"); |
0d863452 RH |
140 | } |
141 | { | |
62ec5f58 | 142 | no warnings "uninitialized"; |
0d863452 | 143 | my $undef; |
62ec5f58 RGS |
144 | my $ok = 0; |
145 | given ($undef) { when(0) {$ok = 1} } | |
cd9c531b | 146 | is($ok, 1, 'Given($undef) when(0)'); |
0d863452 RH |
147 | } |
148 | ######## | |
149 | { | |
150 | my $ok = 1; | |
151 | given ("") { when(undef) {$ok = 0} } | |
cd9c531b | 152 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 RH |
153 | } |
154 | { | |
155 | my $undef; | |
156 | my $ok = 1; | |
157 | given ("") { when($undef) {$ok = 0} } | |
cd9c531b | 158 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 RH |
159 | } |
160 | { | |
62ec5f58 RGS |
161 | no warnings "uninitialized"; |
162 | my $ok = 0; | |
163 | given (undef) { when("") {$ok = 1} } | |
cd9c531b | 164 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 RH |
165 | } |
166 | { | |
62ec5f58 | 167 | no warnings "uninitialized"; |
0d863452 | 168 | my $undef; |
62ec5f58 RGS |
169 | my $ok = 0; |
170 | given ($undef) { when("") {$ok = 1} } | |
cd9c531b | 171 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 RH |
172 | } |
173 | ######## | |
174 | { | |
175 | my $ok = 0; | |
176 | given (undef) { when(undef) {$ok = 1} } | |
cd9c531b | 177 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 RH |
178 | } |
179 | { | |
180 | my $undef; | |
181 | my $ok = 0; | |
182 | given (undef) { when($undef) {$ok = 1} } | |
cd9c531b | 183 | is($ok, 1, 'Given(undef) when($undef)'); |
0d863452 RH |
184 | } |
185 | { | |
186 | my $undef; | |
187 | my $ok = 0; | |
188 | given ($undef) { when(undef) {$ok = 1} } | |
cd9c531b | 189 | is($ok, 1, 'Given($undef) when(undef)'); |
0d863452 RH |
190 | } |
191 | { | |
192 | my $undef; | |
193 | my $ok = 0; | |
194 | given ($undef) { when($undef) {$ok = 1} } | |
cd9c531b | 195 | is($ok, 1, 'Given($undef) when($undef)'); |
0d863452 RH |
196 | } |
197 | ||
198 | ||
199 | # Regular expressions | |
200 | { | |
cd9c531b | 201 | my ($ok1, $ok2); |
0d863452 RH |
202 | given("Hello, world!") { |
203 | when(/lo/) | |
cd9c531b | 204 | { $ok1 = 'y'; continue} |
0d863452 | 205 | when(/no/) |
cd9c531b | 206 | { $ok1 = 'n'; continue} |
0d863452 | 207 | when(/^(Hello,|Goodbye cruel) world[!.?]/) |
cd9c531b | 208 | { $ok2 = 'Y'; continue} |
0d863452 | 209 | when(/^(Hello cruel|Goodbye,) world[!.?]/) |
cd9c531b | 210 | { $ok2 = 'n'; continue} |
0d863452 | 211 | } |
cd9c531b NC |
212 | is($ok1, 'y', "regex 1"); |
213 | is($ok2, 'Y', "regex 2"); | |
0d863452 RH |
214 | } |
215 | ||
216 | # Comparisons | |
217 | { | |
218 | my $test = "explicit numeric comparison (<)"; | |
219 | my $twenty_five = 25; | |
cd9c531b | 220 | my $ok; |
0d863452 | 221 | given($twenty_five) { |
cd9c531b NC |
222 | when ($_ < 10) { $ok = "ten" } |
223 | when ($_ < 20) { $ok = "twenty" } | |
224 | when ($_ < 30) { $ok = "thirty" } | |
225 | when ($_ < 40) { $ok = "forty" } | |
226 | default { $ok = "default" } | |
0d863452 | 227 | } |
cd9c531b | 228 | is($ok, "thirty", $test); |
0d863452 RH |
229 | } |
230 | ||
231 | { | |
232 | use integer; | |
233 | my $test = "explicit numeric comparison (integer <)"; | |
234 | my $twenty_five = 25; | |
cd9c531b | 235 | my $ok; |
0d863452 | 236 | given($twenty_five) { |
cd9c531b NC |
237 | when ($_ < 10) { $ok = "ten" } |
238 | when ($_ < 20) { $ok = "twenty" } | |
239 | when ($_ < 30) { $ok = "thirty" } | |
240 | when ($_ < 40) { $ok = "forty" } | |
241 | default { $ok = "default" } | |
0d863452 | 242 | } |
cd9c531b | 243 | is($ok, "thirty", $test); |
0d863452 RH |
244 | } |
245 | ||
246 | { | |
247 | my $test = "explicit numeric comparison (<=)"; | |
248 | my $twenty_five = 25; | |
cd9c531b | 249 | my $ok; |
0d863452 | 250 | given($twenty_five) { |
cd9c531b NC |
251 | when ($_ <= 10) { $ok = "ten" } |
252 | when ($_ <= 20) { $ok = "twenty" } | |
253 | when ($_ <= 30) { $ok = "thirty" } | |
254 | when ($_ <= 40) { $ok = "forty" } | |
255 | default { $ok = "default" } | |
0d863452 | 256 | } |
cd9c531b | 257 | is($ok, "thirty", $test); |
0d863452 RH |
258 | } |
259 | ||
260 | { | |
261 | use integer; | |
262 | my $test = "explicit numeric comparison (integer <=)"; | |
263 | my $twenty_five = 25; | |
cd9c531b | 264 | my $ok; |
0d863452 | 265 | given($twenty_five) { |
cd9c531b NC |
266 | when ($_ <= 10) { $ok = "ten" } |
267 | when ($_ <= 20) { $ok = "twenty" } | |
268 | when ($_ <= 30) { $ok = "thirty" } | |
269 | when ($_ <= 40) { $ok = "forty" } | |
270 | default { $ok = "default" } | |
0d863452 | 271 | } |
cd9c531b | 272 | is($ok, "thirty", $test); |
0d863452 RH |
273 | } |
274 | ||
275 | ||
276 | { | |
277 | my $test = "explicit numeric comparison (>)"; | |
278 | my $twenty_five = 25; | |
cd9c531b | 279 | my $ok; |
0d863452 | 280 | given($twenty_five) { |
cd9c531b NC |
281 | when ($_ > 40) { $ok = "forty" } |
282 | when ($_ > 30) { $ok = "thirty" } | |
283 | when ($_ > 20) { $ok = "twenty" } | |
284 | when ($_ > 10) { $ok = "ten" } | |
285 | default { $ok = "default" } | |
0d863452 | 286 | } |
cd9c531b | 287 | is($ok, "twenty", $test); |
0d863452 RH |
288 | } |
289 | ||
290 | { | |
291 | my $test = "explicit numeric comparison (>=)"; | |
292 | my $twenty_five = 25; | |
cd9c531b | 293 | my $ok; |
0d863452 | 294 | given($twenty_five) { |
cd9c531b NC |
295 | when ($_ >= 40) { $ok = "forty" } |
296 | when ($_ >= 30) { $ok = "thirty" } | |
297 | when ($_ >= 20) { $ok = "twenty" } | |
298 | when ($_ >= 10) { $ok = "ten" } | |
299 | default { $ok = "default" } | |
0d863452 | 300 | } |
cd9c531b | 301 | is($ok, "twenty", $test); |
0d863452 RH |
302 | } |
303 | ||
304 | { | |
305 | use integer; | |
306 | my $test = "explicit numeric comparison (integer >)"; | |
307 | my $twenty_five = 25; | |
cd9c531b | 308 | my $ok; |
0d863452 | 309 | given($twenty_five) { |
cd9c531b NC |
310 | when ($_ > 40) { $ok = "forty" } |
311 | when ($_ > 30) { $ok = "thirty" } | |
312 | when ($_ > 20) { $ok = "twenty" } | |
313 | when ($_ > 10) { $ok = "ten" } | |
314 | default { $ok = "default" } | |
0d863452 | 315 | } |
cd9c531b | 316 | is($ok, "twenty", $test); |
0d863452 RH |
317 | } |
318 | ||
319 | { | |
320 | use integer; | |
321 | my $test = "explicit numeric comparison (integer >=)"; | |
322 | my $twenty_five = 25; | |
cd9c531b | 323 | my $ok; |
0d863452 | 324 | given($twenty_five) { |
cd9c531b NC |
325 | when ($_ >= 40) { $ok = "forty" } |
326 | when ($_ >= 30) { $ok = "thirty" } | |
327 | when ($_ >= 20) { $ok = "twenty" } | |
328 | when ($_ >= 10) { $ok = "ten" } | |
329 | default { $ok = "default" } | |
0d863452 | 330 | } |
cd9c531b | 331 | is($ok, "twenty", $test); |
0d863452 RH |
332 | } |
333 | ||
334 | ||
335 | { | |
336 | my $test = "explicit string comparison (lt)"; | |
337 | my $twenty_five = "25"; | |
cd9c531b | 338 | my $ok; |
0d863452 | 339 | given($twenty_five) { |
cd9c531b NC |
340 | when ($_ lt "10") { $ok = "ten" } |
341 | when ($_ lt "20") { $ok = "twenty" } | |
342 | when ($_ lt "30") { $ok = "thirty" } | |
343 | when ($_ lt "40") { $ok = "forty" } | |
344 | default { $ok = "default" } | |
0d863452 | 345 | } |
cd9c531b | 346 | is($ok, "thirty", $test); |
0d863452 RH |
347 | } |
348 | ||
349 | { | |
350 | my $test = "explicit string comparison (le)"; | |
351 | my $twenty_five = "25"; | |
cd9c531b | 352 | my $ok; |
0d863452 | 353 | given($twenty_five) { |
cd9c531b NC |
354 | when ($_ le "10") { $ok = "ten" } |
355 | when ($_ le "20") { $ok = "twenty" } | |
356 | when ($_ le "30") { $ok = "thirty" } | |
357 | when ($_ le "40") { $ok = "forty" } | |
358 | default { $ok = "default" } | |
0d863452 | 359 | } |
cd9c531b | 360 | is($ok, "thirty", $test); |
0d863452 RH |
361 | } |
362 | ||
363 | { | |
364 | my $test = "explicit string comparison (gt)"; | |
365 | my $twenty_five = 25; | |
cd9c531b | 366 | my $ok; |
0d863452 | 367 | given($twenty_five) { |
cd9c531b NC |
368 | when ($_ ge "40") { $ok = "forty" } |
369 | when ($_ ge "30") { $ok = "thirty" } | |
370 | when ($_ ge "20") { $ok = "twenty" } | |
371 | when ($_ ge "10") { $ok = "ten" } | |
372 | default { $ok = "default" } | |
0d863452 | 373 | } |
cd9c531b | 374 | is($ok, "twenty", $test); |
0d863452 RH |
375 | } |
376 | ||
377 | { | |
378 | my $test = "explicit string comparison (ge)"; | |
379 | my $twenty_five = 25; | |
cd9c531b | 380 | my $ok; |
0d863452 | 381 | given($twenty_five) { |
cd9c531b NC |
382 | when ($_ ge "40") { $ok = "forty" } |
383 | when ($_ ge "30") { $ok = "thirty" } | |
384 | when ($_ ge "20") { $ok = "twenty" } | |
385 | when ($_ ge "10") { $ok = "ten" } | |
386 | default { $ok = "default" } | |
0d863452 | 387 | } |
cd9c531b | 388 | is($ok, "twenty", $test); |
0d863452 RH |
389 | } |
390 | ||
391 | # Make sure it still works with a lexical $_: | |
392 | { | |
393 | my $_; | |
394 | my $test = "explicit comparison with lexical \$_"; | |
395 | my $twenty_five = 25; | |
cd9c531b | 396 | my $ok; |
0d863452 | 397 | given($twenty_five) { |
cd9c531b NC |
398 | when ($_ ge "40") { $ok = "forty" } |
399 | when ($_ ge "30") { $ok = "thirty" } | |
400 | when ($_ ge "20") { $ok = "twenty" } | |
401 | when ($_ ge "10") { $ok = "ten" } | |
402 | default { $ok = "default" } | |
0d863452 | 403 | } |
cd9c531b | 404 | is($ok, "twenty", $test); |
0d863452 RH |
405 | } |
406 | ||
407 | # Optimized-away comparisons | |
408 | { | |
cd9c531b | 409 | my $ok; |
0d863452 | 410 | given(23) { |
cd9c531b NC |
411 | when (2 + 2 == 4) { $ok = 'y'; continue } |
412 | when (2 + 2 == 5) { $ok = 'n' } | |
0d863452 | 413 | } |
cd9c531b | 414 | is($ok, 'y', "Optimized-away comparison"); |
0d863452 RH |
415 | } |
416 | ||
417 | # File tests | |
418 | # (How to be both thorough and portable? Pinch a few ideas | |
419 | # from t/op/filetest.t. We err on the side of portability for | |
420 | # the time being.) | |
421 | ||
422 | { | |
423 | my ($ok_d, $ok_f, $ok_r); | |
424 | given("op") { | |
425 | when(-d) {$ok_d = 1; continue} | |
426 | when(!-f) {$ok_f = 1; continue} | |
427 | when(-r) {$ok_r = 1; continue} | |
428 | } | |
429 | ok($ok_d, "Filetest -d"); | |
430 | ok($ok_f, "Filetest -f"); | |
431 | ok($ok_r, "Filetest -r"); | |
432 | } | |
433 | ||
434 | # Sub and method calls | |
84c82fbf | 435 | sub notfoo {"bar"} |
0d863452 RH |
436 | { |
437 | my $ok = 0; | |
438 | given("foo") { | |
84c82fbf | 439 | when(notfoo()) {$ok = 1} |
0d863452 RH |
440 | } |
441 | ok($ok, "Sub call acts as boolean") | |
442 | } | |
443 | ||
444 | { | |
445 | my $ok = 0; | |
446 | given("foo") { | |
84c82fbf | 447 | when(main->notfoo()) {$ok = 1} |
0d863452 RH |
448 | } |
449 | ok($ok, "Class-method call acts as boolean") | |
450 | } | |
451 | ||
452 | { | |
453 | my $ok = 0; | |
454 | my $obj = bless []; | |
455 | given("foo") { | |
84c82fbf | 456 | when($obj->notfoo()) {$ok = 1} |
0d863452 RH |
457 | } |
458 | ok($ok, "Object-method call acts as boolean") | |
459 | } | |
460 | ||
461 | # Other things that should not be smart matched | |
462 | { | |
463 | my $ok = 0; | |
1e1d4b91 JJ |
464 | given(12) { |
465 | when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { | |
466 | $ok = 1; | |
467 | } | |
468 | } | |
469 | ok($ok, "bool not smartmatches"); | |
470 | } | |
471 | ||
472 | { | |
473 | my $ok = 0; | |
0d863452 RH |
474 | given(0) { |
475 | when(eof(DATA)) { | |
476 | $ok = 1; | |
477 | } | |
478 | } | |
479 | ok($ok, "eof() not smartmatched"); | |
480 | } | |
481 | ||
482 | { | |
483 | my $ok = 0; | |
484 | my %foo = ("bar", 0); | |
485 | given(0) { | |
486 | when(exists $foo{bar}) { | |
487 | $ok = 1; | |
488 | } | |
489 | } | |
490 | ok($ok, "exists() not smartmatched"); | |
491 | } | |
492 | ||
493 | { | |
494 | my $ok = 0; | |
495 | given(0) { | |
496 | when(defined $ok) { | |
497 | $ok = 1; | |
498 | } | |
499 | } | |
500 | ok($ok, "defined() not smartmatched"); | |
501 | } | |
502 | ||
503 | { | |
504 | my $ok = 1; | |
505 | given("foo") { | |
506 | when((1 == 1) && "bar") { | |
507 | $ok = 0; | |
508 | } | |
509 | when((1 == 1) && $_ eq "foo") { | |
510 | $ok = 2; | |
511 | } | |
512 | } | |
513 | is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); | |
514 | } | |
515 | ||
516 | { | |
6e03d743 RGS |
517 | my $n = 0; |
518 | for my $l qw(a b c d) { | |
519 | given ($l) { | |
520 | when ($_ eq "b" ... $_ eq "c") { $n = 1 } | |
521 | default { $n = 0 } | |
522 | } | |
523 | ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context'); | |
524 | } | |
525 | } | |
526 | ||
527 | { | |
1e1d4b91 JJ |
528 | my $ok = 0; |
529 | given("foo") { | |
0d863452 | 530 | when((1 == $ok) || "foo") { |
1e1d4b91 | 531 | $ok = 1; |
0d863452 RH |
532 | } |
533 | } | |
1e1d4b91 | 534 | ok($ok, '((1 == $ok) || "foo") smartmatched'); |
0d863452 RH |
535 | } |
536 | ||
f92e1a16 RGS |
537 | { |
538 | my $ok = 0; | |
539 | given("foo") { | |
540 | when((1 == $ok || undef) // "foo") { | |
541 | $ok = 1; | |
542 | } | |
543 | } | |
544 | ok($ok, '((1 == $ok || undef) // "foo") smartmatched'); | |
545 | } | |
546 | ||
0d863452 RH |
547 | # Make sure we aren't invoking the get-magic more than once |
548 | ||
549 | { # A helper class to count the number of accesses. | |
550 | package FetchCounter; | |
551 | sub TIESCALAR { | |
552 | my ($class) = @_; | |
553 | bless {value => undef, count => 0}, $class; | |
554 | } | |
555 | sub STORE { | |
556 | my ($self, $val) = @_; | |
557 | $self->{count} = 0; | |
558 | $self->{value} = $val; | |
559 | } | |
560 | sub FETCH { | |
561 | my ($self) = @_; | |
562 | # Avoid pre/post increment here | |
563 | $self->{count} = 1 + $self->{count}; | |
564 | $self->{value}; | |
565 | } | |
566 | sub count { | |
567 | my ($self) = @_; | |
568 | $self->{count}; | |
569 | } | |
570 | } | |
571 | ||
572 | my $f = tie my $v, "FetchCounter"; | |
573 | ||
574 | { my $test_name = "Only one FETCH (in given)"; | |
cd9c531b | 575 | my $ok; |
0d863452 RH |
576 | given($v = 23) { |
577 | when(undef) {} | |
578 | when(sub{0}->()) {} | |
579 | when(21) {} | |
580 | when("22") {} | |
581 | when(23) {$ok = 1} | |
582 | when(/24/) {$ok = 0} | |
583 | } | |
cd9c531b | 584 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
585 | is($f->count(), 1, $test_name); |
586 | } | |
587 | ||
588 | { my $test_name = "Only one FETCH (numeric when)"; | |
cd9c531b | 589 | my $ok; |
0d863452 RH |
590 | $v = 23; |
591 | is($f->count(), 0, "Sanity check: $test_name"); | |
592 | given(23) { | |
593 | when(undef) {} | |
594 | when(sub{0}->()) {} | |
595 | when(21) {} | |
596 | when("22") {} | |
597 | when($v) {$ok = 1} | |
598 | when(/24/) {$ok = 0} | |
599 | } | |
cd9c531b | 600 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
601 | is($f->count(), 1, $test_name); |
602 | } | |
603 | ||
604 | { my $test_name = "Only one FETCH (string when)"; | |
cd9c531b | 605 | my $ok; |
0d863452 RH |
606 | $v = "23"; |
607 | is($f->count(), 0, "Sanity check: $test_name"); | |
608 | given("23") { | |
609 | when(undef) {} | |
610 | when(sub{0}->()) {} | |
611 | when("21") {} | |
612 | when("22") {} | |
613 | when($v) {$ok = 1} | |
614 | when(/24/) {$ok = 0} | |
615 | } | |
cd9c531b | 616 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
617 | is($f->count(), 1, $test_name); |
618 | } | |
619 | ||
620 | { my $test_name = "Only one FETCH (undef)"; | |
cd9c531b | 621 | my $ok; |
0d863452 RH |
622 | $v = undef; |
623 | is($f->count(), 0, "Sanity check: $test_name"); | |
62ec5f58 | 624 | no warnings "uninitialized"; |
0d863452 RH |
625 | given(my $undef) { |
626 | when(sub{0}->()) {} | |
627 | when("21") {} | |
628 | when("22") {} | |
629 | when($v) {$ok = 1} | |
630 | when(undef) {$ok = 0} | |
631 | } | |
cd9c531b | 632 | is($ok, 1, "precheck: $test_name"); |
0d863452 RH |
633 | is($f->count(), 1, $test_name); |
634 | } | |
635 | ||
636 | # Loop topicalizer | |
637 | { | |
638 | my $first = 1; | |
639 | for (1, "two") { | |
640 | when ("two") { | |
641 | is($first, 0, "Loop: second"); | |
642 | eval {break}; | |
643 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
644 | q{Can't "break" in a loop topicalizer}); | |
645 | } | |
646 | when (1) { | |
647 | is($first, 1, "Loop: first"); | |
648 | $first = 0; | |
649 | # Implicit break is okay | |
650 | } | |
651 | } | |
652 | } | |
653 | ||
654 | { | |
655 | my $first = 1; | |
656 | for $_ (1, "two") { | |
657 | when ("two") { | |
658 | is($first, 0, "Explicit \$_: second"); | |
659 | eval {break}; | |
660 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
661 | q{Can't "break" in a loop topicalizer}); | |
662 | } | |
663 | when (1) { | |
664 | is($first, 1, "Explicit \$_: first"); | |
665 | $first = 0; | |
666 | # Implicit break is okay | |
667 | } | |
668 | } | |
669 | } | |
670 | ||
671 | { | |
672 | my $first = 1; | |
673 | my $_; | |
674 | for (1, "two") { | |
675 | when ("two") { | |
676 | is($first, 0, "Implicitly lexical loop: second"); | |
677 | eval {break}; | |
678 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
679 | q{Can't "break" in a loop topicalizer}); | |
680 | } | |
681 | when (1) { | |
682 | is($first, 1, "Implicitly lexical loop: first"); | |
683 | $first = 0; | |
684 | # Implicit break is okay | |
685 | } | |
686 | } | |
687 | } | |
688 | ||
689 | { | |
690 | my $first = 1; | |
691 | my $_; | |
692 | for $_ (1, "two") { | |
693 | when ("two") { | |
694 | is($first, 0, "Implicitly lexical, explicit \$_: second"); | |
695 | eval {break}; | |
696 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
697 | q{Can't "break" in a loop topicalizer}); | |
698 | } | |
699 | when (1) { | |
700 | is($first, 1, "Implicitly lexical, explicit \$_: first"); | |
701 | $first = 0; | |
702 | # Implicit break is okay | |
703 | } | |
704 | } | |
705 | } | |
706 | ||
707 | { | |
708 | my $first = 1; | |
709 | for my $_ (1, "two") { | |
710 | when ("two") { | |
711 | is($first, 0, "Lexical loop: second"); | |
712 | eval {break}; | |
713 | like($@, qr/^Can't "break" in a loop topicalizer/, | |
714 | q{Can't "break" in a loop topicalizer}); | |
715 | } | |
716 | when (1) { | |
1dcb720a | 717 | is($first, 1, "Lexical loop: first"); |
0d863452 RH |
718 | $first = 0; |
719 | # Implicit break is okay | |
720 | } | |
721 | } | |
722 | } | |
723 | ||
724 | ||
725 | # Code references | |
726 | { | |
727 | no warnings "redefine"; | |
728 | my $called_foo = 0; | |
84c82fbf | 729 | sub foo {$called_foo = 1; "@_" eq "foo"} |
0d863452 | 730 | my $called_bar = 0; |
84c82fbf | 731 | sub bar {$called_bar = 1; "@_" eq "bar"} |
0d863452 | 732 | my ($matched_foo, $matched_bar) = (0, 0); |
84c82fbf | 733 | given("foo") { |
0d863452 RH |
734 | when(\&bar) {$matched_bar = 1} |
735 | when(\&foo) {$matched_foo = 1} | |
736 | } | |
84c82fbf RGS |
737 | is($called_foo, 1, "foo() was called"); |
738 | is($called_bar, 1, "bar() was called"); | |
739 | is($matched_bar, 0, "bar didn't match"); | |
740 | is($matched_foo, 1, "foo did match"); | |
0d863452 RH |
741 | } |
742 | ||
743 | sub contains_x { | |
744 | my $x = shift; | |
745 | return ($x =~ /x/); | |
746 | } | |
747 | { | |
748 | my ($ok1, $ok2) = (0,0); | |
749 | given("foxy!") { | |
750 | when(contains_x($_)) | |
751 | { $ok1 = 1; continue } | |
752 | when(\&contains_x) | |
753 | { $ok2 = 1; continue } | |
754 | } | |
755 | is($ok1, 1, "Calling sub directly (true)"); | |
756 | is($ok2, 1, "Calling sub indirectly (true)"); | |
757 | ||
758 | given("foggy") { | |
759 | when(contains_x($_)) | |
760 | { $ok1 = 2; continue } | |
761 | when(\&contains_x) | |
762 | { $ok2 = 2; continue } | |
763 | } | |
764 | is($ok1, 1, "Calling sub directly (false)"); | |
765 | is($ok2, 1, "Calling sub indirectly (false)"); | |
766 | } | |
767 | ||
02eafbe2 DD |
768 | SKIP: { |
769 | skip "Scalar/Util.pm not yet available", 20 | |
770 | unless -r "$INC[0]/Scalar/Util.pm"; | |
771 | # Test overloading | |
772 | { package OverloadTest; | |
773 | ||
774 | use overload '""' => sub{"string value of obj"}; | |
775 | ||
776 | use overload "~~" => sub { | |
777 | my ($self, $other, $reversed) = @_; | |
778 | if ($reversed) { | |
779 | $self->{left} = $other; | |
780 | $self->{right} = $self; | |
781 | $self->{reversed} = 1; | |
782 | } else { | |
783 | $self->{left} = $self; | |
784 | $self->{right} = $other; | |
785 | $self->{reversed} = 0; | |
786 | } | |
787 | $self->{called} = 1; | |
788 | return $self->{retval}; | |
789 | }; | |
0d863452 | 790 | |
02eafbe2 DD |
791 | sub new { |
792 | my ($pkg, $retval) = @_; | |
793 | bless { | |
794 | called => 0, | |
795 | retval => $retval, | |
796 | }, $pkg; | |
797 | } | |
798 | } | |
799 | ||
800 | { | |
801 | my $test = "Overloaded obj in given (true)"; | |
802 | my $obj = OverloadTest->new(1); | |
803 | my $matched; | |
804 | given($obj) { | |
805 | when ("other arg") {$matched = 1} | |
806 | default {$matched = 0} | |
807 | } | |
0d863452 | 808 | |
02eafbe2 DD |
809 | is($obj->{called}, 1, "$test: called"); |
810 | ok($matched, "$test: matched"); | |
811 | is($obj->{left}, "string value of obj", "$test: left"); | |
812 | is($obj->{right}, "other arg", "$test: right"); | |
813 | ok(!$obj->{reversed}, "$test: not reversed"); | |
814 | } | |
815 | ||
816 | { | |
817 | my $test = "Overloaded obj in given (false)"; | |
818 | my $obj = OverloadTest->new(0); | |
819 | my $matched; | |
820 | given($obj) { | |
821 | when ("other arg") {$matched = 1} | |
822 | } | |
0d863452 | 823 | |
02eafbe2 DD |
824 | is($obj->{called}, 1, "$test: called"); |
825 | ok(!$matched, "$test: not matched"); | |
826 | is($obj->{left}, "string value of obj", "$test: left"); | |
827 | is($obj->{right}, "other arg", "$test: right"); | |
828 | ok(!$obj->{reversed}, "$test: not reversed"); | |
829 | } | |
830 | ||
831 | { | |
832 | my $test = "Overloaded obj in when (true)"; | |
833 | my $obj = OverloadTest->new(1); | |
834 | my $matched; | |
835 | given("topic") { | |
836 | when ($obj) {$matched = 1} | |
837 | default {$matched = 0} | |
838 | } | |
0d863452 | 839 | |
02eafbe2 DD |
840 | is($obj->{called}, 1, "$test: called"); |
841 | ok($matched, "$test: matched"); | |
842 | is($obj->{left}, "topic", "$test: left"); | |
843 | is($obj->{right}, "string value of obj", "$test: right"); | |
844 | ok($obj->{reversed}, "$test: reversed"); | |
845 | } | |
846 | ||
847 | { | |
848 | my $test = "Overloaded obj in when (false)"; | |
849 | my $obj = OverloadTest->new(0); | |
850 | my $matched; | |
851 | given("topic") { | |
852 | when ($obj) {$matched = 1} | |
853 | default {$matched = 0} | |
854 | } | |
0d863452 | 855 | |
02eafbe2 DD |
856 | is($obj->{called}, 1, "$test: called"); |
857 | ok(!$matched, "$test: not matched"); | |
858 | is($obj->{left}, "topic", "$test: left"); | |
859 | is($obj->{right}, "string value of obj", "$test: right"); | |
860 | ok($obj->{reversed}, "$test: reversed"); | |
861 | } | |
0d863452 | 862 | } |
0d863452 RH |
863 | # Okay, that'll do for now. The intricacies of the smartmatch |
864 | # semantics are tested in t/op/smartmatch.t | |
865 | __END__ |