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 | ||
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 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 | { | |
136 | my $ok = 1; | |
137 | given (undef) { when(0) {$ok = 0} } | |
cd9c531b | 138 | is($ok, 1, "Given(undef) when(0)"); |
0d863452 RH |
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 RH |
145 | } |
146 | ######## | |
147 | { | |
148 | my $ok = 1; | |
149 | given ("") { when(undef) {$ok = 0} } | |
cd9c531b | 150 | is($ok, 1, 'Given("") when(undef)'); |
0d863452 RH |
151 | } |
152 | { | |
153 | my $undef; | |
154 | my $ok = 1; | |
155 | given ("") { when($undef) {$ok = 0} } | |
cd9c531b | 156 | is($ok, 1, 'Given("") when($undef)'); |
0d863452 RH |
157 | } |
158 | { | |
159 | my $ok = 1; | |
160 | given (undef) { when("") {$ok = 0} } | |
cd9c531b | 161 | is($ok, 1, 'Given(undef) when("")'); |
0d863452 RH |
162 | } |
163 | { | |
164 | my $undef; | |
165 | my $ok = 1; | |
166 | given ($undef) { when("") {$ok = 0} } | |
cd9c531b | 167 | is($ok, 1, 'Given($undef) when("")'); |
0d863452 RH |
168 | } |
169 | ######## | |
170 | { | |
171 | my $ok = 0; | |
172 | given (undef) { when(undef) {$ok = 1} } | |
cd9c531b | 173 | is($ok, 1, "Given(undef) when(undef)"); |
0d863452 RH |
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 RH |
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 RH |
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 RH |
192 | } |
193 | ||
194 | ||
195 | # Regular expressions | |
196 | { | |
cd9c531b | 197 | my ($ok1, $ok2); |
0d863452 RH |
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 NC |
208 | is($ok1, 'y', "regex 1"); |
209 | is($ok2, 'Y', "regex 2"); | |
0d863452 RH |
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 NC |
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 RH |
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 NC |
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 RH |
240 | } |
241 | ||
242 | { | |
243 | my $test = "explicit numeric comparison (<=)"; | |
244 | my $twenty_five = 25; | |
cd9c531b | 245 | my $ok; |
0d863452 | 246 | given($twenty_five) { |
cd9c531b NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
284 | } |
285 | ||
286 | { | |
287 | my $test = "explicit numeric comparison (>=)"; | |
288 | my $twenty_five = 25; | |
cd9c531b | 289 | my $ok; |
0d863452 | 290 | given($twenty_five) { |
cd9c531b NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
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 NC |
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 RH |
401 | } |
402 | ||
403 | # Optimized-away comparisons | |
404 | { | |
cd9c531b | 405 | my $ok; |
0d863452 | 406 | given(23) { |
cd9c531b NC |
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 RH |
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 RH |
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 RH |
551 | is($f->count(), 1, $test_name); |
552 | } | |
553 | ||
554 | { my $test_name = "Only one FETCH (numeric when)"; | |
cd9c531b | 555 | my $ok; |
0d863452 RH |
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 RH |
567 | is($f->count(), 1, $test_name); |
568 | } | |
569 | ||
570 | { my $test_name = "Only one FETCH (string when)"; | |
cd9c531b | 571 | my $ok; |
0d863452 RH |
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 RH |
583 | is($f->count(), 1, $test_name); |
584 | } | |
585 | ||
586 | { my $test_name = "Only one FETCH (undef)"; | |
cd9c531b | 587 | my $ok; |
0d863452 RH |
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 RH |
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__ |