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 | |
1e1d4b91 |
11 | use Test::More tests => 108; |
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 | { |
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; |
1e1d4b91 |
460 | given(12) { |
461 | when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) { |
462 | $ok = 1; |
463 | } |
464 | } |
465 | ok($ok, "bool not smartmatches"); |
466 | } |
467 | |
468 | { |
469 | my $ok = 0; |
0d863452 |
470 | given(0) { |
471 | when(eof(DATA)) { |
472 | $ok = 1; |
473 | } |
474 | } |
475 | ok($ok, "eof() not smartmatched"); |
476 | } |
477 | |
478 | { |
479 | my $ok = 0; |
480 | my %foo = ("bar", 0); |
481 | given(0) { |
482 | when(exists $foo{bar}) { |
483 | $ok = 1; |
484 | } |
485 | } |
486 | ok($ok, "exists() not smartmatched"); |
487 | } |
488 | |
489 | { |
490 | my $ok = 0; |
491 | given(0) { |
492 | when(defined $ok) { |
493 | $ok = 1; |
494 | } |
495 | } |
496 | ok($ok, "defined() not smartmatched"); |
497 | } |
498 | |
499 | { |
500 | my $ok = 1; |
501 | given("foo") { |
502 | when((1 == 1) && "bar") { |
503 | $ok = 0; |
504 | } |
505 | when((1 == 1) && $_ eq "foo") { |
506 | $ok = 2; |
507 | } |
508 | } |
509 | is($ok, 2, "((1 == 1) && \"bar\") not smartmatched"); |
510 | } |
511 | |
512 | { |
1e1d4b91 |
513 | my $ok = 0; |
514 | given("foo") { |
0d863452 |
515 | when((1 == $ok) || "foo") { |
1e1d4b91 |
516 | $ok = 1; |
0d863452 |
517 | } |
518 | } |
1e1d4b91 |
519 | ok($ok, '((1 == $ok) || "foo") smartmatched'); |
0d863452 |
520 | } |
521 | |
522 | |
523 | # Make sure we aren't invoking the get-magic more than once |
524 | |
525 | { # A helper class to count the number of accesses. |
526 | package FetchCounter; |
527 | sub TIESCALAR { |
528 | my ($class) = @_; |
529 | bless {value => undef, count => 0}, $class; |
530 | } |
531 | sub STORE { |
532 | my ($self, $val) = @_; |
533 | $self->{count} = 0; |
534 | $self->{value} = $val; |
535 | } |
536 | sub FETCH { |
537 | my ($self) = @_; |
538 | # Avoid pre/post increment here |
539 | $self->{count} = 1 + $self->{count}; |
540 | $self->{value}; |
541 | } |
542 | sub count { |
543 | my ($self) = @_; |
544 | $self->{count}; |
545 | } |
546 | } |
547 | |
548 | my $f = tie my $v, "FetchCounter"; |
549 | |
550 | { my $test_name = "Only one FETCH (in given)"; |
cd9c531b |
551 | my $ok; |
0d863452 |
552 | given($v = 23) { |
553 | when(undef) {} |
554 | when(sub{0}->()) {} |
555 | when(21) {} |
556 | when("22") {} |
557 | when(23) {$ok = 1} |
558 | when(/24/) {$ok = 0} |
559 | } |
cd9c531b |
560 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
561 | is($f->count(), 1, $test_name); |
562 | } |
563 | |
564 | { my $test_name = "Only one FETCH (numeric when)"; |
cd9c531b |
565 | my $ok; |
0d863452 |
566 | $v = 23; |
567 | is($f->count(), 0, "Sanity check: $test_name"); |
568 | given(23) { |
569 | when(undef) {} |
570 | when(sub{0}->()) {} |
571 | when(21) {} |
572 | when("22") {} |
573 | when($v) {$ok = 1} |
574 | when(/24/) {$ok = 0} |
575 | } |
cd9c531b |
576 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
577 | is($f->count(), 1, $test_name); |
578 | } |
579 | |
580 | { my $test_name = "Only one FETCH (string when)"; |
cd9c531b |
581 | my $ok; |
0d863452 |
582 | $v = "23"; |
583 | is($f->count(), 0, "Sanity check: $test_name"); |
584 | given("23") { |
585 | when(undef) {} |
586 | when(sub{0}->()) {} |
587 | when("21") {} |
588 | when("22") {} |
589 | when($v) {$ok = 1} |
590 | when(/24/) {$ok = 0} |
591 | } |
cd9c531b |
592 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
593 | is($f->count(), 1, $test_name); |
594 | } |
595 | |
596 | { my $test_name = "Only one FETCH (undef)"; |
cd9c531b |
597 | my $ok; |
0d863452 |
598 | $v = undef; |
599 | is($f->count(), 0, "Sanity check: $test_name"); |
600 | given(my $undef) { |
601 | when(sub{0}->()) {} |
602 | when("21") {} |
603 | when("22") {} |
604 | when($v) {$ok = 1} |
605 | when(undef) {$ok = 0} |
606 | } |
cd9c531b |
607 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
608 | is($f->count(), 1, $test_name); |
609 | } |
610 | |
611 | # Loop topicalizer |
612 | { |
613 | my $first = 1; |
614 | for (1, "two") { |
615 | when ("two") { |
616 | is($first, 0, "Loop: second"); |
617 | eval {break}; |
618 | like($@, qr/^Can't "break" in a loop topicalizer/, |
619 | q{Can't "break" in a loop topicalizer}); |
620 | } |
621 | when (1) { |
622 | is($first, 1, "Loop: first"); |
623 | $first = 0; |
624 | # Implicit break is okay |
625 | } |
626 | } |
627 | } |
628 | |
629 | { |
630 | my $first = 1; |
631 | for $_ (1, "two") { |
632 | when ("two") { |
633 | is($first, 0, "Explicit \$_: second"); |
634 | eval {break}; |
635 | like($@, qr/^Can't "break" in a loop topicalizer/, |
636 | q{Can't "break" in a loop topicalizer}); |
637 | } |
638 | when (1) { |
639 | is($first, 1, "Explicit \$_: first"); |
640 | $first = 0; |
641 | # Implicit break is okay |
642 | } |
643 | } |
644 | } |
645 | |
646 | { |
647 | my $first = 1; |
648 | my $_; |
649 | for (1, "two") { |
650 | when ("two") { |
651 | is($first, 0, "Implicitly lexical loop: second"); |
652 | eval {break}; |
653 | like($@, qr/^Can't "break" in a loop topicalizer/, |
654 | q{Can't "break" in a loop topicalizer}); |
655 | } |
656 | when (1) { |
657 | is($first, 1, "Implicitly lexical loop: first"); |
658 | $first = 0; |
659 | # Implicit break is okay |
660 | } |
661 | } |
662 | } |
663 | |
664 | { |
665 | my $first = 1; |
666 | my $_; |
667 | for $_ (1, "two") { |
668 | when ("two") { |
669 | is($first, 0, "Implicitly lexical, explicit \$_: second"); |
670 | eval {break}; |
671 | like($@, qr/^Can't "break" in a loop topicalizer/, |
672 | q{Can't "break" in a loop topicalizer}); |
673 | } |
674 | when (1) { |
675 | is($first, 1, "Implicitly lexical, explicit \$_: first"); |
676 | $first = 0; |
677 | # Implicit break is okay |
678 | } |
679 | } |
680 | } |
681 | |
682 | { |
683 | my $first = 1; |
684 | for my $_ (1, "two") { |
685 | when ("two") { |
686 | is($first, 0, "Lexical loop: second"); |
687 | eval {break}; |
688 | like($@, qr/^Can't "break" in a loop topicalizer/, |
689 | q{Can't "break" in a loop topicalizer}); |
690 | } |
691 | when (1) { |
692 | is($first, 1, "Lecical loop: first"); |
693 | $first = 0; |
694 | # Implicit break is okay |
695 | } |
696 | } |
697 | } |
698 | |
699 | |
700 | # Code references |
701 | { |
702 | no warnings "redefine"; |
703 | my $called_foo = 0; |
704 | sub foo {$called_foo = 1} |
705 | my $called_bar = 0; |
706 | sub bar {$called_bar = 1} |
707 | my ($matched_foo, $matched_bar) = (0, 0); |
708 | given(\&foo) { |
709 | when(\&bar) {$matched_bar = 1} |
710 | when(\&foo) {$matched_foo = 1} |
711 | } |
712 | is($called_foo, 0, "Code ref comparison: foo not called"); |
713 | is($called_bar, 0, "Code ref comparison: bar not called"); |
714 | is($matched_bar, 0, "Code ref didn't match different one"); |
715 | is($matched_foo, 1, "Code ref did match itself"); |
716 | } |
717 | |
718 | sub contains_x { |
719 | my $x = shift; |
720 | return ($x =~ /x/); |
721 | } |
722 | { |
723 | my ($ok1, $ok2) = (0,0); |
724 | given("foxy!") { |
725 | when(contains_x($_)) |
726 | { $ok1 = 1; continue } |
727 | when(\&contains_x) |
728 | { $ok2 = 1; continue } |
729 | } |
730 | is($ok1, 1, "Calling sub directly (true)"); |
731 | is($ok2, 1, "Calling sub indirectly (true)"); |
732 | |
733 | given("foggy") { |
734 | when(contains_x($_)) |
735 | { $ok1 = 2; continue } |
736 | when(\&contains_x) |
737 | { $ok2 = 2; continue } |
738 | } |
739 | is($ok1, 1, "Calling sub directly (false)"); |
740 | is($ok2, 1, "Calling sub indirectly (false)"); |
741 | } |
742 | |
743 | # Test overloading |
744 | { package OverloadTest; |
745 | |
746 | use overload '""' => sub{"string value of obj"}; |
747 | |
748 | use overload "~~" => sub { |
749 | my ($self, $other, $reversed) = @_; |
750 | if ($reversed) { |
751 | $self->{left} = $other; |
752 | $self->{right} = $self; |
753 | $self->{reversed} = 1; |
754 | } else { |
755 | $self->{left} = $self; |
756 | $self->{right} = $other; |
757 | $self->{reversed} = 0; |
758 | } |
759 | $self->{called} = 1; |
760 | return $self->{retval}; |
761 | }; |
762 | |
763 | sub new { |
764 | my ($pkg, $retval) = @_; |
765 | bless { |
766 | called => 0, |
767 | retval => $retval, |
768 | }, $pkg; |
769 | } |
770 | } |
771 | |
772 | { |
773 | my $test = "Overloaded obj in given (true)"; |
774 | my $obj = OverloadTest->new(1); |
775 | my $matched; |
776 | given($obj) { |
777 | when ("other arg") {$matched = 1} |
778 | default {$matched = 0} |
779 | } |
780 | |
781 | is($obj->{called}, 1, "$test: called"); |
782 | ok($matched, "$test: matched"); |
783 | is($obj->{left}, "string value of obj", "$test: left"); |
784 | is($obj->{right}, "other arg", "$test: right"); |
785 | ok(!$obj->{reversed}, "$test: not reversed"); |
786 | } |
787 | |
788 | { |
789 | my $test = "Overloaded obj in given (false)"; |
790 | my $obj = OverloadTest->new(0); |
791 | my $matched; |
792 | given($obj) { |
793 | when ("other arg") {$matched = 1} |
794 | } |
795 | |
796 | is($obj->{called}, 1, "$test: called"); |
797 | ok(!$matched, "$test: not matched"); |
798 | is($obj->{left}, "string value of obj", "$test: left"); |
799 | is($obj->{right}, "other arg", "$test: right"); |
800 | ok(!$obj->{reversed}, "$test: not reversed"); |
801 | } |
802 | |
803 | { |
804 | my $test = "Overloaded obj in when (true)"; |
805 | my $obj = OverloadTest->new(1); |
806 | my $matched; |
807 | given("topic") { |
808 | when ($obj) {$matched = 1} |
809 | default {$matched = 0} |
810 | } |
811 | |
812 | is($obj->{called}, 1, "$test: called"); |
813 | ok($matched, "$test: matched"); |
814 | is($obj->{left}, "topic", "$test: left"); |
815 | is($obj->{right}, "string value of obj", "$test: right"); |
816 | ok($obj->{reversed}, "$test: reversed"); |
817 | } |
818 | |
819 | { |
820 | my $test = "Overloaded obj in when (false)"; |
821 | my $obj = OverloadTest->new(0); |
822 | my $matched; |
823 | given("topic") { |
824 | when ($obj) {$matched = 1} |
825 | default {$matched = 0} |
826 | } |
827 | |
828 | is($obj->{called}, 1, "$test: called"); |
829 | ok(!$matched, "$test: not matched"); |
830 | is($obj->{left}, "topic", "$test: left"); |
831 | is($obj->{right}, "string value of obj", "$test: right"); |
832 | ok($obj->{reversed}, "$test: reversed"); |
833 | } |
834 | |
835 | # Okay, that'll do for now. The intricacies of the smartmatch |
836 | # semantics are tested in t/op/smartmatch.t |
837 | __END__ |