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 | |
11 | use Test::More tests => 107; |
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 | { |
136 | my $ok = 1; |
137 | given (undef) { when(0) {$ok = 0} } |
cd9c531b |
138 | is($ok, 1, "Given(undef) when(0)"); |
0d863452 |
139 | } |
140 | { |
141 | my $undef; |
142 | my $ok = 1; |
143 | given ($undef) { when(0) {$ok = 0} } |
cd9c531b |
144 | is($ok, 1, 'Given($undef) when(0)'); |
0d863452 |
145 | } |
146 | ######## |
147 | { |
148 | my $ok = 1; |
149 | given ("") { when(undef) {$ok = 0} } |
cd9c531b |
150 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 |
151 | } |
152 | { |
153 | my $undef; |
154 | my $ok = 1; |
155 | given ("") { when($undef) {$ok = 0} } |
cd9c531b |
156 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 |
157 | } |
158 | { |
159 | my $ok = 1; |
160 | given (undef) { when("") {$ok = 0} } |
cd9c531b |
161 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 |
162 | } |
163 | { |
164 | my $undef; |
165 | my $ok = 1; |
166 | given ($undef) { when("") {$ok = 0} } |
cd9c531b |
167 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 |
168 | } |
169 | ######## |
170 | { |
171 | my $ok = 0; |
172 | given (undef) { when(undef) {$ok = 1} } |
cd9c531b |
173 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 |
174 | } |
175 | { |
176 | my $undef; |
177 | my $ok = 0; |
178 | given (undef) { when($undef) {$ok = 1} } |
cd9c531b |
179 | is($ok, 1, 'Given(undef) when($undef)'); |
0d863452 |
180 | } |
181 | { |
182 | my $undef; |
183 | my $ok = 0; |
184 | given ($undef) { when(undef) {$ok = 1} } |
cd9c531b |
185 | is($ok, 1, 'Given($undef) when(undef)'); |
0d863452 |
186 | } |
187 | { |
188 | my $undef; |
189 | my $ok = 0; |
190 | given ($undef) { when($undef) {$ok = 1} } |
cd9c531b |
191 | is($ok, 1, 'Given($undef) when($undef)'); |
0d863452 |
192 | } |
193 | |
194 | |
195 | # Regular expressions |
196 | { |
cd9c531b |
197 | my ($ok1, $ok2); |
0d863452 |
198 | given("Hello, world!") { |
199 | when(/lo/) |
cd9c531b |
200 | { $ok1 = 'y'; continue} |
0d863452 |
201 | when(/no/) |
cd9c531b |
202 | { $ok1 = 'n'; continue} |
0d863452 |
203 | when(/^(Hello,|Goodbye cruel) world[!.?]/) |
cd9c531b |
204 | { $ok2 = 'Y'; continue} |
0d863452 |
205 | when(/^(Hello cruel|Goodbye,) world[!.?]/) |
cd9c531b |
206 | { $ok2 = 'n'; continue} |
0d863452 |
207 | } |
cd9c531b |
208 | is($ok1, 'y', "regex 1"); |
209 | is($ok2, 'Y', "regex 2"); |
0d863452 |
210 | } |
211 | |
212 | # Comparisons |
213 | { |
214 | my $test = "explicit numeric comparison (<)"; |
215 | my $twenty_five = 25; |
cd9c531b |
216 | my $ok; |
0d863452 |
217 | given($twenty_five) { |
cd9c531b |
218 | when ($_ < 10) { $ok = "ten" } |
219 | when ($_ < 20) { $ok = "twenty" } |
220 | when ($_ < 30) { $ok = "thirty" } |
221 | when ($_ < 40) { $ok = "forty" } |
222 | default { $ok = "default" } |
0d863452 |
223 | } |
cd9c531b |
224 | is($ok, "thirty", $test); |
0d863452 |
225 | } |
226 | |
227 | { |
228 | use integer; |
229 | my $test = "explicit numeric comparison (integer <)"; |
230 | my $twenty_five = 25; |
cd9c531b |
231 | my $ok; |
0d863452 |
232 | given($twenty_five) { |
cd9c531b |
233 | when ($_ < 10) { $ok = "ten" } |
234 | when ($_ < 20) { $ok = "twenty" } |
235 | when ($_ < 30) { $ok = "thirty" } |
236 | when ($_ < 40) { $ok = "forty" } |
237 | default { $ok = "default" } |
0d863452 |
238 | } |
cd9c531b |
239 | is($ok, "thirty", $test); |
0d863452 |
240 | } |
241 | |
242 | { |
243 | my $test = "explicit numeric comparison (<=)"; |
244 | my $twenty_five = 25; |
cd9c531b |
245 | my $ok; |
0d863452 |
246 | given($twenty_five) { |
cd9c531b |
247 | when ($_ <= 10) { $ok = "ten" } |
248 | when ($_ <= 20) { $ok = "twenty" } |
249 | when ($_ <= 30) { $ok = "thirty" } |
250 | when ($_ <= 40) { $ok = "forty" } |
251 | default { $ok = "default" } |
0d863452 |
252 | } |
cd9c531b |
253 | is($ok, "thirty", $test); |
0d863452 |
254 | } |
255 | |
256 | { |
257 | use integer; |
258 | my $test = "explicit numeric comparison (integer <=)"; |
259 | my $twenty_five = 25; |
cd9c531b |
260 | my $ok; |
0d863452 |
261 | given($twenty_five) { |
cd9c531b |
262 | when ($_ <= 10) { $ok = "ten" } |
263 | when ($_ <= 20) { $ok = "twenty" } |
264 | when ($_ <= 30) { $ok = "thirty" } |
265 | when ($_ <= 40) { $ok = "forty" } |
266 | default { $ok = "default" } |
0d863452 |
267 | } |
cd9c531b |
268 | is($ok, "thirty", $test); |
0d863452 |
269 | } |
270 | |
271 | |
272 | { |
273 | my $test = "explicit numeric comparison (>)"; |
274 | my $twenty_five = 25; |
cd9c531b |
275 | my $ok; |
0d863452 |
276 | given($twenty_five) { |
cd9c531b |
277 | when ($_ > 40) { $ok = "forty" } |
278 | when ($_ > 30) { $ok = "thirty" } |
279 | when ($_ > 20) { $ok = "twenty" } |
280 | when ($_ > 10) { $ok = "ten" } |
281 | default { $ok = "default" } |
0d863452 |
282 | } |
cd9c531b |
283 | is($ok, "twenty", $test); |
0d863452 |
284 | } |
285 | |
286 | { |
287 | my $test = "explicit numeric comparison (>=)"; |
288 | my $twenty_five = 25; |
cd9c531b |
289 | my $ok; |
0d863452 |
290 | given($twenty_five) { |
cd9c531b |
291 | when ($_ >= 40) { $ok = "forty" } |
292 | when ($_ >= 30) { $ok = "thirty" } |
293 | when ($_ >= 20) { $ok = "twenty" } |
294 | when ($_ >= 10) { $ok = "ten" } |
295 | default { $ok = "default" } |
0d863452 |
296 | } |
cd9c531b |
297 | is($ok, "twenty", $test); |
0d863452 |
298 | } |
299 | |
300 | { |
301 | use integer; |
302 | my $test = "explicit numeric comparison (integer >)"; |
303 | my $twenty_five = 25; |
cd9c531b |
304 | my $ok; |
0d863452 |
305 | given($twenty_five) { |
cd9c531b |
306 | when ($_ > 40) { $ok = "forty" } |
307 | when ($_ > 30) { $ok = "thirty" } |
308 | when ($_ > 20) { $ok = "twenty" } |
309 | when ($_ > 10) { $ok = "ten" } |
310 | default { $ok = "default" } |
0d863452 |
311 | } |
cd9c531b |
312 | is($ok, "twenty", $test); |
0d863452 |
313 | } |
314 | |
315 | { |
316 | use integer; |
317 | my $test = "explicit numeric comparison (integer >=)"; |
318 | my $twenty_five = 25; |
cd9c531b |
319 | my $ok; |
0d863452 |
320 | given($twenty_five) { |
cd9c531b |
321 | when ($_ >= 40) { $ok = "forty" } |
322 | when ($_ >= 30) { $ok = "thirty" } |
323 | when ($_ >= 20) { $ok = "twenty" } |
324 | when ($_ >= 10) { $ok = "ten" } |
325 | default { $ok = "default" } |
0d863452 |
326 | } |
cd9c531b |
327 | is($ok, "twenty", $test); |
0d863452 |
328 | } |
329 | |
330 | |
331 | { |
332 | my $test = "explicit string comparison (lt)"; |
333 | my $twenty_five = "25"; |
cd9c531b |
334 | my $ok; |
0d863452 |
335 | given($twenty_five) { |
cd9c531b |
336 | when ($_ lt "10") { $ok = "ten" } |
337 | when ($_ lt "20") { $ok = "twenty" } |
338 | when ($_ lt "30") { $ok = "thirty" } |
339 | when ($_ lt "40") { $ok = "forty" } |
340 | default { $ok = "default" } |
0d863452 |
341 | } |
cd9c531b |
342 | is($ok, "thirty", $test); |
0d863452 |
343 | } |
344 | |
345 | { |
346 | my $test = "explicit string comparison (le)"; |
347 | my $twenty_five = "25"; |
cd9c531b |
348 | my $ok; |
0d863452 |
349 | given($twenty_five) { |
cd9c531b |
350 | when ($_ le "10") { $ok = "ten" } |
351 | when ($_ le "20") { $ok = "twenty" } |
352 | when ($_ le "30") { $ok = "thirty" } |
353 | when ($_ le "40") { $ok = "forty" } |
354 | default { $ok = "default" } |
0d863452 |
355 | } |
cd9c531b |
356 | is($ok, "thirty", $test); |
0d863452 |
357 | } |
358 | |
359 | { |
360 | my $test = "explicit string comparison (gt)"; |
361 | my $twenty_five = 25; |
cd9c531b |
362 | my $ok; |
0d863452 |
363 | given($twenty_five) { |
cd9c531b |
364 | when ($_ ge "40") { $ok = "forty" } |
365 | when ($_ ge "30") { $ok = "thirty" } |
366 | when ($_ ge "20") { $ok = "twenty" } |
367 | when ($_ ge "10") { $ok = "ten" } |
368 | default { $ok = "default" } |
0d863452 |
369 | } |
cd9c531b |
370 | is($ok, "twenty", $test); |
0d863452 |
371 | } |
372 | |
373 | { |
374 | my $test = "explicit string comparison (ge)"; |
375 | my $twenty_five = 25; |
cd9c531b |
376 | my $ok; |
0d863452 |
377 | given($twenty_five) { |
cd9c531b |
378 | when ($_ ge "40") { $ok = "forty" } |
379 | when ($_ ge "30") { $ok = "thirty" } |
380 | when ($_ ge "20") { $ok = "twenty" } |
381 | when ($_ ge "10") { $ok = "ten" } |
382 | default { $ok = "default" } |
0d863452 |
383 | } |
cd9c531b |
384 | is($ok, "twenty", $test); |
0d863452 |
385 | } |
386 | |
387 | # Make sure it still works with a lexical $_: |
388 | { |
389 | my $_; |
390 | my $test = "explicit comparison with lexical \$_"; |
391 | my $twenty_five = 25; |
cd9c531b |
392 | my $ok; |
0d863452 |
393 | given($twenty_five) { |
cd9c531b |
394 | when ($_ ge "40") { $ok = "forty" } |
395 | when ($_ ge "30") { $ok = "thirty" } |
396 | when ($_ ge "20") { $ok = "twenty" } |
397 | when ($_ ge "10") { $ok = "ten" } |
398 | default { $ok = "default" } |
0d863452 |
399 | } |
cd9c531b |
400 | is($ok, "twenty", $test); |
0d863452 |
401 | } |
402 | |
403 | # Optimized-away comparisons |
404 | { |
cd9c531b |
405 | my $ok; |
0d863452 |
406 | given(23) { |
cd9c531b |
407 | when (2 + 2 == 4) { $ok = 'y'; continue } |
408 | when (2 + 2 == 5) { $ok = 'n' } |
0d863452 |
409 | } |
cd9c531b |
410 | is($ok, 'y', "Optimized-away comparison"); |
0d863452 |
411 | } |
412 | |
413 | # File tests |
414 | # (How to be both thorough and portable? Pinch a few ideas |
415 | # from t/op/filetest.t. We err on the side of portability for |
416 | # the time being.) |
417 | |
418 | { |
419 | my ($ok_d, $ok_f, $ok_r); |
420 | given("op") { |
421 | when(-d) {$ok_d = 1; continue} |
422 | when(!-f) {$ok_f = 1; continue} |
423 | when(-r) {$ok_r = 1; continue} |
424 | } |
425 | ok($ok_d, "Filetest -d"); |
426 | ok($ok_f, "Filetest -f"); |
427 | ok($ok_r, "Filetest -r"); |
428 | } |
429 | |
430 | # Sub and method calls |
431 | sub bar {"bar"} |
432 | { |
433 | my $ok = 0; |
434 | given("foo") { |
435 | when(bar()) {$ok = 1} |
436 | } |
437 | ok($ok, "Sub call acts as boolean") |
438 | } |
439 | |
440 | { |
441 | my $ok = 0; |
442 | given("foo") { |
443 | when(main->bar()) {$ok = 1} |
444 | } |
445 | ok($ok, "Class-method call acts as boolean") |
446 | } |
447 | |
448 | { |
449 | my $ok = 0; |
450 | my $obj = bless []; |
451 | given("foo") { |
452 | when($obj->bar()) {$ok = 1} |
453 | } |
454 | ok($ok, "Object-method call acts as boolean") |
455 | } |
456 | |
457 | # Other things that should not be smart matched |
458 | { |
459 | my $ok = 0; |
460 | given(0) { |
461 | when(eof(DATA)) { |
462 | $ok = 1; |
463 | } |
464 | } |
465 | ok($ok, "eof() not smartmatched"); |
466 | } |
467 | |
468 | { |
469 | my $ok = 0; |
470 | my %foo = ("bar", 0); |
471 | given(0) { |
472 | when(exists $foo{bar}) { |
473 | $ok = 1; |
474 | } |
475 | } |
476 | ok($ok, "exists() not smartmatched"); |
477 | } |
478 | |
479 | { |
480 | my $ok = 0; |
481 | given(0) { |
482 | when(defined $ok) { |
483 | $ok = 1; |
484 | } |
485 | } |
486 | ok($ok, "defined() not smartmatched"); |
487 | } |
488 | |
489 | { |
490 | my $ok = 1; |
491 | given("foo") { |
492 | when((1 == 1) && "bar") { |
493 | $ok = 0; |
494 | } |
495 | when((1 == 1) && $_ eq "foo") { |
496 | $ok = 2; |
497 | } |
498 | } |
499 | is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); |
500 | } |
501 | |
502 | { |
503 | my $ok = 1; |
504 | given(0) { |
505 | when((1 == $ok) || "foo") { |
506 | $ok = 0; |
507 | } |
508 | } |
509 | ok($ok, '((1 == $ok) || "foo") not smartmatched'); |
510 | } |
511 | |
512 | |
513 | # Make sure we aren't invoking the get-magic more than once |
514 | |
515 | { # A helper class to count the number of accesses. |
516 | package FetchCounter; |
517 | sub TIESCALAR { |
518 | my ($class) = @_; |
519 | bless {value => undef, count => 0}, $class; |
520 | } |
521 | sub STORE { |
522 | my ($self, $val) = @_; |
523 | $self->{count} = 0; |
524 | $self->{value} = $val; |
525 | } |
526 | sub FETCH { |
527 | my ($self) = @_; |
528 | # Avoid pre/post increment here |
529 | $self->{count} = 1 + $self->{count}; |
530 | $self->{value}; |
531 | } |
532 | sub count { |
533 | my ($self) = @_; |
534 | $self->{count}; |
535 | } |
536 | } |
537 | |
538 | my $f = tie my $v, "FetchCounter"; |
539 | |
540 | { my $test_name = "Only one FETCH (in given)"; |
cd9c531b |
541 | my $ok; |
0d863452 |
542 | given($v = 23) { |
543 | when(undef) {} |
544 | when(sub{0}->()) {} |
545 | when(21) {} |
546 | when("22") {} |
547 | when(23) {$ok = 1} |
548 | when(/24/) {$ok = 0} |
549 | } |
cd9c531b |
550 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
551 | is($f->count(), 1, $test_name); |
552 | } |
553 | |
554 | { my $test_name = "Only one FETCH (numeric when)"; |
cd9c531b |
555 | my $ok; |
0d863452 |
556 | $v = 23; |
557 | is($f->count(), 0, "Sanity check: $test_name"); |
558 | given(23) { |
559 | when(undef) {} |
560 | when(sub{0}->()) {} |
561 | when(21) {} |
562 | when("22") {} |
563 | when($v) {$ok = 1} |
564 | when(/24/) {$ok = 0} |
565 | } |
cd9c531b |
566 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
567 | is($f->count(), 1, $test_name); |
568 | } |
569 | |
570 | { my $test_name = "Only one FETCH (string when)"; |
cd9c531b |
571 | my $ok; |
0d863452 |
572 | $v = "23"; |
573 | is($f->count(), 0, "Sanity check: $test_name"); |
574 | given("23") { |
575 | when(undef) {} |
576 | when(sub{0}->()) {} |
577 | when("21") {} |
578 | when("22") {} |
579 | when($v) {$ok = 1} |
580 | when(/24/) {$ok = 0} |
581 | } |
cd9c531b |
582 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
583 | is($f->count(), 1, $test_name); |
584 | } |
585 | |
586 | { my $test_name = "Only one FETCH (undef)"; |
cd9c531b |
587 | my $ok; |
0d863452 |
588 | $v = undef; |
589 | is($f->count(), 0, "Sanity check: $test_name"); |
590 | given(my $undef) { |
591 | when(sub{0}->()) {} |
592 | when("21") {} |
593 | when("22") {} |
594 | when($v) {$ok = 1} |
595 | when(undef) {$ok = 0} |
596 | } |
cd9c531b |
597 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
598 | is($f->count(), 1, $test_name); |
599 | } |
600 | |
601 | # Loop topicalizer |
602 | { |
603 | my $first = 1; |
604 | for (1, "two") { |
605 | when ("two") { |
606 | is($first, 0, "Loop: second"); |
607 | eval {break}; |
608 | like($@, qr/^Can't "break" in a loop topicalizer/, |
609 | q{Can't "break" in a loop topicalizer}); |
610 | } |
611 | when (1) { |
612 | is($first, 1, "Loop: first"); |
613 | $first = 0; |
614 | # Implicit break is okay |
615 | } |
616 | } |
617 | } |
618 | |
619 | { |
620 | my $first = 1; |
621 | for $_ (1, "two") { |
622 | when ("two") { |
623 | is($first, 0, "Explicit \$_: second"); |
624 | eval {break}; |
625 | like($@, qr/^Can't "break" in a loop topicalizer/, |
626 | q{Can't "break" in a loop topicalizer}); |
627 | } |
628 | when (1) { |
629 | is($first, 1, "Explicit \$_: first"); |
630 | $first = 0; |
631 | # Implicit break is okay |
632 | } |
633 | } |
634 | } |
635 | |
636 | { |
637 | my $first = 1; |
638 | my $_; |
639 | for (1, "two") { |
640 | when ("two") { |
641 | is($first, 0, "Implicitly lexical 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, "Implicitly lexical loop: first"); |
648 | $first = 0; |
649 | # Implicit break is okay |
650 | } |
651 | } |
652 | } |
653 | |
654 | { |
655 | my $first = 1; |
656 | my $_; |
657 | for $_ (1, "two") { |
658 | when ("two") { |
659 | is($first, 0, "Implicitly lexical, explicit \$_: second"); |
660 | eval {break}; |
661 | like($@, qr/^Can't "break" in a loop topicalizer/, |
662 | q{Can't "break" in a loop topicalizer}); |
663 | } |
664 | when (1) { |
665 | is($first, 1, "Implicitly lexical, explicit \$_: first"); |
666 | $first = 0; |
667 | # Implicit break is okay |
668 | } |
669 | } |
670 | } |
671 | |
672 | { |
673 | my $first = 1; |
674 | for my $_ (1, "two") { |
675 | when ("two") { |
676 | is($first, 0, "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, "Lecical loop: first"); |
683 | $first = 0; |
684 | # Implicit break is okay |
685 | } |
686 | } |
687 | } |
688 | |
689 | |
690 | # Code references |
691 | { |
692 | no warnings "redefine"; |
693 | my $called_foo = 0; |
694 | sub foo {$called_foo = 1} |
695 | my $called_bar = 0; |
696 | sub bar {$called_bar = 1} |
697 | my ($matched_foo, $matched_bar) = (0, 0); |
698 | given(\&foo) { |
699 | when(\&bar) {$matched_bar = 1} |
700 | when(\&foo) {$matched_foo = 1} |
701 | } |
702 | is($called_foo, 0, "Code ref comparison: foo not called"); |
703 | is($called_bar, 0, "Code ref comparison: bar not called"); |
704 | is($matched_bar, 0, "Code ref didn't match different one"); |
705 | is($matched_foo, 1, "Code ref did match itself"); |
706 | } |
707 | |
708 | sub contains_x { |
709 | my $x = shift; |
710 | return ($x =~ /x/); |
711 | } |
712 | { |
713 | my ($ok1, $ok2) = (0,0); |
714 | given("foxy!") { |
715 | when(contains_x($_)) |
716 | { $ok1 = 1; continue } |
717 | when(\&contains_x) |
718 | { $ok2 = 1; continue } |
719 | } |
720 | is($ok1, 1, "Calling sub directly (true)"); |
721 | is($ok2, 1, "Calling sub indirectly (true)"); |
722 | |
723 | given("foggy") { |
724 | when(contains_x($_)) |
725 | { $ok1 = 2; continue } |
726 | when(\&contains_x) |
727 | { $ok2 = 2; continue } |
728 | } |
729 | is($ok1, 1, "Calling sub directly (false)"); |
730 | is($ok2, 1, "Calling sub indirectly (false)"); |
731 | } |
732 | |
733 | # Test overloading |
734 | { package OverloadTest; |
735 | |
736 | use overload '""' => sub{"string value of obj"}; |
737 | |
738 | use overload "~~" => sub { |
739 | my ($self, $other, $reversed) = @_; |
740 | if ($reversed) { |
741 | $self->{left} = $other; |
742 | $self->{right} = $self; |
743 | $self->{reversed} = 1; |
744 | } else { |
745 | $self->{left} = $self; |
746 | $self->{right} = $other; |
747 | $self->{reversed} = 0; |
748 | } |
749 | $self->{called} = 1; |
750 | return $self->{retval}; |
751 | }; |
752 | |
753 | sub new { |
754 | my ($pkg, $retval) = @_; |
755 | bless { |
756 | called => 0, |
757 | retval => $retval, |
758 | }, $pkg; |
759 | } |
760 | } |
761 | |
762 | { |
763 | my $test = "Overloaded obj in given (true)"; |
764 | my $obj = OverloadTest->new(1); |
765 | my $matched; |
766 | given($obj) { |
767 | when ("other arg") {$matched = 1} |
768 | default {$matched = 0} |
769 | } |
770 | |
771 | is($obj->{called}, 1, "$test: called"); |
772 | ok($matched, "$test: matched"); |
773 | is($obj->{left}, "string value of obj", "$test: left"); |
774 | is($obj->{right}, "other arg", "$test: right"); |
775 | ok(!$obj->{reversed}, "$test: not reversed"); |
776 | } |
777 | |
778 | { |
779 | my $test = "Overloaded obj in given (false)"; |
780 | my $obj = OverloadTest->new(0); |
781 | my $matched; |
782 | given($obj) { |
783 | when ("other arg") {$matched = 1} |
784 | } |
785 | |
786 | is($obj->{called}, 1, "$test: called"); |
787 | ok(!$matched, "$test: not matched"); |
788 | is($obj->{left}, "string value of obj", "$test: left"); |
789 | is($obj->{right}, "other arg", "$test: right"); |
790 | ok(!$obj->{reversed}, "$test: not reversed"); |
791 | } |
792 | |
793 | { |
794 | my $test = "Overloaded obj in when (true)"; |
795 | my $obj = OverloadTest->new(1); |
796 | my $matched; |
797 | given("topic") { |
798 | when ($obj) {$matched = 1} |
799 | default {$matched = 0} |
800 | } |
801 | |
802 | is($obj->{called}, 1, "$test: called"); |
803 | ok($matched, "$test: matched"); |
804 | is($obj->{left}, "topic", "$test: left"); |
805 | is($obj->{right}, "string value of obj", "$test: right"); |
806 | ok($obj->{reversed}, "$test: reversed"); |
807 | } |
808 | |
809 | { |
810 | my $test = "Overloaded obj in when (false)"; |
811 | my $obj = OverloadTest->new(0); |
812 | my $matched; |
813 | given("topic") { |
814 | when ($obj) {$matched = 1} |
815 | default {$matched = 0} |
816 | } |
817 | |
818 | is($obj->{called}, 1, "$test: called"); |
819 | ok(!$matched, "$test: not matched"); |
820 | is($obj->{left}, "topic", "$test: left"); |
821 | is($obj->{right}, "string value of obj", "$test: right"); |
822 | ok($obj->{reversed}, "$test: reversed"); |
823 | } |
824 | |
825 | # Okay, that'll do for now. The intricacies of the smartmatch |
826 | # semantics are tested in t/op/smartmatch.t |
827 | __END__ |