Commit | Line | Data |
0d863452 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use strict; |
9 | use warnings; |
10 | |
6d743019 |
11 | use Test::More tests => 118; |
0d863452 |
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 |
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 |
69 | } |
70 | |
71 | { |
cd9c531b |
72 | my $ok; |
0d863452 |
73 | use integer; |
74 | given(3.14159265) { |
cd9c531b |
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 |
81 | } |
82 | |
83 | { |
cd9c531b |
84 | my ($ok1, $ok2); |
0d863452 |
85 | given(3) { |
cd9c531b |
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 |
91 | is($ok1, 'y', "more numeric (pt. 1)"); |
92 | is($ok2, 'y', "more numeric (pt. 2)"); |
0d863452 |
93 | } |
94 | |
95 | { |
cd9c531b |
96 | my $ok; |
0d863452 |
97 | given("c") { |
cd9c531b |
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 |
104 | } |
105 | |
106 | { |
cd9c531b |
107 | my $ok; |
0d863452 |
108 | given("c") { |
cd9c531b |
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 |
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 |
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 |
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 |
134 | } |
135 | { |
62ec5f58 |
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 |
140 | } |
141 | { |
62ec5f58 |
142 | no warnings "uninitialized"; |
0d863452 |
143 | my $undef; |
62ec5f58 |
144 | my $ok = 0; |
145 | given ($undef) { when(0) {$ok = 1} } |
cd9c531b |
146 | is($ok, 1, 'Given($undef) when(0)'); |
0d863452 |
147 | } |
148 | ######## |
149 | { |
150 | my $ok = 1; |
151 | given ("") { when(undef) {$ok = 0} } |
cd9c531b |
152 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 |
153 | } |
154 | { |
155 | my $undef; |
156 | my $ok = 1; |
157 | given ("") { when($undef) {$ok = 0} } |
cd9c531b |
158 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 |
159 | } |
160 | { |
62ec5f58 |
161 | no warnings "uninitialized"; |
162 | my $ok = 0; |
163 | given (undef) { when("") {$ok = 1} } |
cd9c531b |
164 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 |
165 | } |
166 | { |
62ec5f58 |
167 | no warnings "uninitialized"; |
0d863452 |
168 | my $undef; |
62ec5f58 |
169 | my $ok = 0; |
170 | given ($undef) { when("") {$ok = 1} } |
cd9c531b |
171 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 |
172 | } |
173 | ######## |
174 | { |
175 | my $ok = 0; |
176 | given (undef) { when(undef) {$ok = 1} } |
cd9c531b |
177 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 |
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 |
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 |
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 |
196 | } |
197 | |
198 | |
199 | # Regular expressions |
200 | { |
cd9c531b |
201 | my ($ok1, $ok2); |
0d863452 |
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 |
212 | is($ok1, 'y', "regex 1"); |
213 | is($ok2, 'Y', "regex 2"); |
0d863452 |
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 |
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 |
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 |
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 |
244 | } |
245 | |
246 | { |
247 | my $test = "explicit numeric comparison (<=)"; |
248 | my $twenty_five = 25; |
cd9c531b |
249 | my $ok; |
0d863452 |
250 | given($twenty_five) { |
cd9c531b |
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 |
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 |
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 |
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 |
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 |
288 | } |
289 | |
290 | { |
291 | my $test = "explicit numeric comparison (>=)"; |
292 | my $twenty_five = 25; |
cd9c531b |
293 | my $ok; |
0d863452 |
294 | given($twenty_five) { |
cd9c531b |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
405 | } |
406 | |
407 | # Optimized-away comparisons |
408 | { |
cd9c531b |
409 | my $ok; |
0d863452 |
410 | given(23) { |
cd9c531b |
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 |
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 |
436 | { |
437 | my $ok = 0; |
438 | given("foo") { |
84c82fbf |
439 | when(notfoo()) {$ok = 1} |
0d863452 |
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 |
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 |
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 |
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 |
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 |
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 |
528 | my $ok = 0; |
529 | given("foo") { |
0d863452 |
530 | when((1 == $ok) || "foo") { |
1e1d4b91 |
531 | $ok = 1; |
0d863452 |
532 | } |
533 | } |
1e1d4b91 |
534 | ok($ok, '((1 == $ok) || "foo") smartmatched'); |
0d863452 |
535 | } |
536 | |
f92e1a16 |
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 |
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 |
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 |
585 | is($f->count(), 1, $test_name); |
586 | } |
587 | |
588 | { my $test_name = "Only one FETCH (numeric when)"; |
cd9c531b |
589 | my $ok; |
0d863452 |
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 |
601 | is($f->count(), 1, $test_name); |
602 | } |
603 | |
604 | { my $test_name = "Only one FETCH (string when)"; |
cd9c531b |
605 | my $ok; |
0d863452 |
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 |
617 | is($f->count(), 1, $test_name); |
618 | } |
619 | |
620 | { my $test_name = "Only one FETCH (undef)"; |
cd9c531b |
621 | my $ok; |
0d863452 |
622 | $v = undef; |
623 | is($f->count(), 0, "Sanity check: $test_name"); |
62ec5f58 |
624 | no warnings "uninitialized"; |
0d863452 |
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 |
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 |
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 |
734 | when(\&bar) {$matched_bar = 1} |
735 | when(\&foo) {$matched_foo = 1} |
736 | } |
84c82fbf |
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 |
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 |
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"}; |
6d743019 |
775 | use overload 'eq' => sub{"$_[0]" eq "$_[1]"}; |
02eafbe2 |
776 | |
777 | use overload "~~" => sub { |
778 | my ($self, $other, $reversed) = @_; |
779 | if ($reversed) { |
780 | $self->{left} = $other; |
781 | $self->{right} = $self; |
782 | $self->{reversed} = 1; |
783 | } else { |
784 | $self->{left} = $self; |
785 | $self->{right} = $other; |
786 | $self->{reversed} = 0; |
787 | } |
788 | $self->{called} = 1; |
789 | return $self->{retval}; |
790 | }; |
0d863452 |
791 | |
02eafbe2 |
792 | sub new { |
793 | my ($pkg, $retval) = @_; |
794 | bless { |
795 | called => 0, |
796 | retval => $retval, |
797 | }, $pkg; |
798 | } |
799 | } |
800 | |
801 | { |
802 | my $test = "Overloaded obj in given (true)"; |
803 | my $obj = OverloadTest->new(1); |
804 | my $matched; |
805 | given($obj) { |
806 | when ("other arg") {$matched = 1} |
807 | default {$matched = 0} |
808 | } |
0d863452 |
809 | |
6d743019 |
810 | is($obj->{called}, 0, "$test: called"); |
811 | ok(!$matched, "$test: not matched"); |
02eafbe2 |
812 | } |
813 | |
814 | { |
815 | my $test = "Overloaded obj in given (false)"; |
816 | my $obj = OverloadTest->new(0); |
817 | my $matched; |
818 | given($obj) { |
819 | when ("other arg") {$matched = 1} |
820 | } |
0d863452 |
821 | |
6d743019 |
822 | is($obj->{called}, 0, "$test: called"); |
02eafbe2 |
823 | ok(!$matched, "$test: not matched"); |
02eafbe2 |
824 | } |
825 | |
826 | { |
827 | my $test = "Overloaded obj in when (true)"; |
828 | my $obj = OverloadTest->new(1); |
829 | my $matched; |
830 | given("topic") { |
831 | when ($obj) {$matched = 1} |
832 | default {$matched = 0} |
833 | } |
0d863452 |
834 | |
02eafbe2 |
835 | is($obj->{called}, 1, "$test: called"); |
836 | ok($matched, "$test: matched"); |
837 | is($obj->{left}, "topic", "$test: left"); |
838 | is($obj->{right}, "string value of obj", "$test: right"); |
839 | ok($obj->{reversed}, "$test: reversed"); |
840 | } |
841 | |
842 | { |
843 | my $test = "Overloaded obj in when (false)"; |
844 | my $obj = OverloadTest->new(0); |
845 | my $matched; |
846 | given("topic") { |
847 | when ($obj) {$matched = 1} |
848 | default {$matched = 0} |
849 | } |
0d863452 |
850 | |
02eafbe2 |
851 | is($obj->{called}, 1, "$test: called"); |
852 | ok(!$matched, "$test: not matched"); |
853 | is($obj->{left}, "topic", "$test: left"); |
854 | is($obj->{right}, "string value of obj", "$test: right"); |
855 | ok($obj->{reversed}, "$test: reversed"); |
856 | } |
0d863452 |
857 | } |
f20dcd76 |
858 | |
859 | # Postfix when |
860 | { |
861 | my $ok; |
862 | given (undef) { |
863 | $ok = 1 when undef; |
864 | } |
865 | is($ok, 1, "postfix undef"); |
866 | } |
867 | { |
868 | my $ok; |
869 | given (2) { |
870 | $ok += 1 when 7; |
871 | $ok += 2 when 9.1685; |
872 | $ok += 4 when $_ > 4; |
873 | $ok += 8 when $_ < 2.5; |
874 | } |
875 | is($ok, 8, "postfix numeric"); |
876 | } |
877 | { |
878 | my $ok; |
879 | given ("apple") { |
880 | $ok = 1, continue when $_ eq "apple"; |
881 | $ok += 2; |
882 | $ok = 0 when "banana"; |
883 | } |
884 | is($ok, 3, "postfix string"); |
885 | } |
886 | { |
887 | my $ok; |
888 | given ("pear") { |
889 | do { $ok = 1; continue } when /pea/; |
890 | $ok += 2; |
891 | $ok = 0 when /pie/; |
892 | default { $ok += 4 } |
893 | $ok = 0; |
894 | } |
895 | is($ok, 7, "postfix regex"); |
896 | } |
897 | # be_true is defined at the beginning of the file |
898 | { |
899 | my $x = "what"; |
900 | given(my $x = "foo") { |
901 | do { |
902 | is($x, "foo", "scope inside ... when my \$x = ..."); |
903 | continue; |
904 | } when be_true(my $x = "bar"); |
905 | is($x, "bar", "scope after ... when my \$x = ..."); |
906 | } |
907 | } |
908 | { |
909 | my $x = 0; |
910 | given(my $x = 1) { |
911 | my $x = 2, continue when be_true(); |
912 | is($x, undef, "scope after my \$x = ... when ..."); |
913 | } |
914 | } |
915 | |
1ebfab32 |
916 | # Tests for last and next in when clauses |
917 | my $letter; |
918 | |
919 | $letter = ''; |
920 | for ("a".."e") { |
921 | given ($_) { |
922 | $letter = $_; |
923 | when ("b") { last } |
924 | } |
925 | $letter = "z"; |
926 | } |
927 | is($letter, "b", "last in when"); |
928 | |
929 | $letter = ''; |
930 | LETTER1: for ("a".."e") { |
931 | given ($_) { |
932 | $letter = $_; |
933 | when ("b") { last LETTER1 } |
934 | } |
935 | $letter = "z"; |
936 | } |
937 | is($letter, "b", "last LABEL in when"); |
938 | |
939 | $letter = ''; |
940 | for ("a".."e") { |
941 | given ($_) { |
942 | when (/b|d/) { next } |
943 | $letter .= $_; |
944 | } |
945 | $letter .= ','; |
946 | } |
947 | is($letter, "a,c,e,", "next in when"); |
948 | |
949 | $letter = ''; |
950 | LETTER2: for ("a".."e") { |
951 | given ($_) { |
952 | when (/b|d/) { next LETTER2 } |
953 | $letter .= $_; |
954 | } |
955 | $letter .= ','; |
956 | } |
957 | is($letter, "a,c,e,", "next LABEL in when"); |
f20dcd76 |
958 | |
0d863452 |
959 | # Okay, that'll do for now. The intricacies of the smartmatch |
960 | # semantics are tested in t/op/smartmatch.t |
961 | __END__ |