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 | |
1dcb720a |
11 | use Test::More tests => 111; |
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 | |
1dcb720a |
522 | TODO: { |
523 | local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match"; |
524 | { # this should smart match on each side of && |
525 | my @n = qw(fred barney betty); |
526 | my @m = @n; |
527 | |
528 | my $ok = 0; |
529 | given( "fred" ) { |
530 | when( @n ) { |
531 | $ok++; continue; |
532 | } |
533 | when( @m ) { |
534 | $ok++; continue; |
535 | } |
536 | when( @m && @n ) { |
537 | $ok++; |
538 | } |
539 | } |
540 | |
541 | is($ok, 3, '(@n && @m) smart-matched'); |
542 | } |
543 | |
544 | { # this should smart match on each side of && |
545 | my @n = qw(fred barney betty); |
546 | my %n = map { $_, 1 } @n; |
547 | |
548 | my $ok = 0; |
549 | given( "fred" ) { |
550 | when( @n ) { |
551 | $ok++; continue; |
552 | } |
553 | when( %n ) { |
554 | $ok++; continue; |
555 | } |
556 | when( @n && %n ) { |
557 | $ok++; |
558 | } |
559 | } |
560 | |
561 | is($ok, 3, '(@n && %n) smart-matched'); |
562 | } |
563 | |
564 | { # this should smart match on each side of && |
565 | my %n = map { $_, 1 } qw(fred barney betty); |
566 | my %m = %n; |
567 | |
568 | my $ok = 0; |
569 | given( "fred" ) { |
570 | when( %m ) { |
571 | $ok++; continue; |
572 | } |
573 | when( %n ) { |
574 | $ok++; continue; |
575 | } |
576 | when( %m && %n ) { |
577 | $ok++; |
578 | } |
579 | } |
580 | |
581 | is($ok, 3, '(%m && %n) smart-matched'); |
582 | } |
583 | } |
0d863452 |
584 | |
585 | # Make sure we aren't invoking the get-magic more than once |
586 | |
587 | { # A helper class to count the number of accesses. |
588 | package FetchCounter; |
589 | sub TIESCALAR { |
590 | my ($class) = @_; |
591 | bless {value => undef, count => 0}, $class; |
592 | } |
593 | sub STORE { |
594 | my ($self, $val) = @_; |
595 | $self->{count} = 0; |
596 | $self->{value} = $val; |
597 | } |
598 | sub FETCH { |
599 | my ($self) = @_; |
600 | # Avoid pre/post increment here |
601 | $self->{count} = 1 + $self->{count}; |
602 | $self->{value}; |
603 | } |
604 | sub count { |
605 | my ($self) = @_; |
606 | $self->{count}; |
607 | } |
608 | } |
609 | |
610 | my $f = tie my $v, "FetchCounter"; |
611 | |
612 | { my $test_name = "Only one FETCH (in given)"; |
cd9c531b |
613 | my $ok; |
0d863452 |
614 | given($v = 23) { |
615 | when(undef) {} |
616 | when(sub{0}->()) {} |
617 | when(21) {} |
618 | when("22") {} |
619 | when(23) {$ok = 1} |
620 | when(/24/) {$ok = 0} |
621 | } |
cd9c531b |
622 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
623 | is($f->count(), 1, $test_name); |
624 | } |
625 | |
626 | { my $test_name = "Only one FETCH (numeric when)"; |
cd9c531b |
627 | my $ok; |
0d863452 |
628 | $v = 23; |
629 | is($f->count(), 0, "Sanity check: $test_name"); |
630 | given(23) { |
631 | when(undef) {} |
632 | when(sub{0}->()) {} |
633 | when(21) {} |
634 | when("22") {} |
635 | when($v) {$ok = 1} |
636 | when(/24/) {$ok = 0} |
637 | } |
cd9c531b |
638 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
639 | is($f->count(), 1, $test_name); |
640 | } |
641 | |
642 | { my $test_name = "Only one FETCH (string when)"; |
cd9c531b |
643 | my $ok; |
0d863452 |
644 | $v = "23"; |
645 | is($f->count(), 0, "Sanity check: $test_name"); |
646 | given("23") { |
647 | when(undef) {} |
648 | when(sub{0}->()) {} |
649 | when("21") {} |
650 | when("22") {} |
651 | when($v) {$ok = 1} |
652 | when(/24/) {$ok = 0} |
653 | } |
cd9c531b |
654 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
655 | is($f->count(), 1, $test_name); |
656 | } |
657 | |
658 | { my $test_name = "Only one FETCH (undef)"; |
cd9c531b |
659 | my $ok; |
0d863452 |
660 | $v = undef; |
661 | is($f->count(), 0, "Sanity check: $test_name"); |
662 | given(my $undef) { |
663 | when(sub{0}->()) {} |
664 | when("21") {} |
665 | when("22") {} |
666 | when($v) {$ok = 1} |
667 | when(undef) {$ok = 0} |
668 | } |
cd9c531b |
669 | is($ok, 1, "precheck: $test_name"); |
0d863452 |
670 | is($f->count(), 1, $test_name); |
671 | } |
672 | |
673 | # Loop topicalizer |
674 | { |
675 | my $first = 1; |
676 | for (1, "two") { |
677 | when ("two") { |
678 | is($first, 0, "Loop: second"); |
679 | eval {break}; |
680 | like($@, qr/^Can't "break" in a loop topicalizer/, |
681 | q{Can't "break" in a loop topicalizer}); |
682 | } |
683 | when (1) { |
684 | is($first, 1, "Loop: first"); |
685 | $first = 0; |
686 | # Implicit break is okay |
687 | } |
688 | } |
689 | } |
690 | |
691 | { |
692 | my $first = 1; |
693 | for $_ (1, "two") { |
694 | when ("two") { |
695 | is($first, 0, "Explicit \$_: second"); |
696 | eval {break}; |
697 | like($@, qr/^Can't "break" in a loop topicalizer/, |
698 | q{Can't "break" in a loop topicalizer}); |
699 | } |
700 | when (1) { |
701 | is($first, 1, "Explicit \$_: first"); |
702 | $first = 0; |
703 | # Implicit break is okay |
704 | } |
705 | } |
706 | } |
707 | |
708 | { |
709 | my $first = 1; |
710 | my $_; |
711 | for (1, "two") { |
712 | when ("two") { |
713 | is($first, 0, "Implicitly lexical loop: second"); |
714 | eval {break}; |
715 | like($@, qr/^Can't "break" in a loop topicalizer/, |
716 | q{Can't "break" in a loop topicalizer}); |
717 | } |
718 | when (1) { |
719 | is($first, 1, "Implicitly lexical loop: first"); |
720 | $first = 0; |
721 | # Implicit break is okay |
722 | } |
723 | } |
724 | } |
725 | |
726 | { |
727 | my $first = 1; |
728 | my $_; |
729 | for $_ (1, "two") { |
730 | when ("two") { |
731 | is($first, 0, "Implicitly lexical, explicit \$_: second"); |
732 | eval {break}; |
733 | like($@, qr/^Can't "break" in a loop topicalizer/, |
734 | q{Can't "break" in a loop topicalizer}); |
735 | } |
736 | when (1) { |
737 | is($first, 1, "Implicitly lexical, explicit \$_: first"); |
738 | $first = 0; |
739 | # Implicit break is okay |
740 | } |
741 | } |
742 | } |
743 | |
744 | { |
745 | my $first = 1; |
746 | for my $_ (1, "two") { |
747 | when ("two") { |
748 | is($first, 0, "Lexical loop: second"); |
749 | eval {break}; |
750 | like($@, qr/^Can't "break" in a loop topicalizer/, |
751 | q{Can't "break" in a loop topicalizer}); |
752 | } |
753 | when (1) { |
1dcb720a |
754 | is($first, 1, "Lexical loop: first"); |
0d863452 |
755 | $first = 0; |
756 | # Implicit break is okay |
757 | } |
758 | } |
759 | } |
760 | |
761 | |
762 | # Code references |
763 | { |
764 | no warnings "redefine"; |
765 | my $called_foo = 0; |
766 | sub foo {$called_foo = 1} |
767 | my $called_bar = 0; |
768 | sub bar {$called_bar = 1} |
769 | my ($matched_foo, $matched_bar) = (0, 0); |
770 | given(\&foo) { |
771 | when(\&bar) {$matched_bar = 1} |
772 | when(\&foo) {$matched_foo = 1} |
773 | } |
774 | is($called_foo, 0, "Code ref comparison: foo not called"); |
775 | is($called_bar, 0, "Code ref comparison: bar not called"); |
776 | is($matched_bar, 0, "Code ref didn't match different one"); |
777 | is($matched_foo, 1, "Code ref did match itself"); |
778 | } |
779 | |
780 | sub contains_x { |
781 | my $x = shift; |
782 | return ($x =~ /x/); |
783 | } |
784 | { |
785 | my ($ok1, $ok2) = (0,0); |
786 | given("foxy!") { |
787 | when(contains_x($_)) |
788 | { $ok1 = 1; continue } |
789 | when(\&contains_x) |
790 | { $ok2 = 1; continue } |
791 | } |
792 | is($ok1, 1, "Calling sub directly (true)"); |
793 | is($ok2, 1, "Calling sub indirectly (true)"); |
794 | |
795 | given("foggy") { |
796 | when(contains_x($_)) |
797 | { $ok1 = 2; continue } |
798 | when(\&contains_x) |
799 | { $ok2 = 2; continue } |
800 | } |
801 | is($ok1, 1, "Calling sub directly (false)"); |
802 | is($ok2, 1, "Calling sub indirectly (false)"); |
803 | } |
804 | |
02eafbe2 |
805 | SKIP: { |
806 | skip "Scalar/Util.pm not yet available", 20 |
807 | unless -r "$INC[0]/Scalar/Util.pm"; |
808 | # Test overloading |
809 | { package OverloadTest; |
810 | |
811 | use overload '""' => sub{"string value of obj"}; |
812 | |
813 | use overload "~~" => sub { |
814 | my ($self, $other, $reversed) = @_; |
815 | if ($reversed) { |
816 | $self->{left} = $other; |
817 | $self->{right} = $self; |
818 | $self->{reversed} = 1; |
819 | } else { |
820 | $self->{left} = $self; |
821 | $self->{right} = $other; |
822 | $self->{reversed} = 0; |
823 | } |
824 | $self->{called} = 1; |
825 | return $self->{retval}; |
826 | }; |
0d863452 |
827 | |
02eafbe2 |
828 | sub new { |
829 | my ($pkg, $retval) = @_; |
830 | bless { |
831 | called => 0, |
832 | retval => $retval, |
833 | }, $pkg; |
834 | } |
835 | } |
836 | |
837 | { |
838 | my $test = "Overloaded obj in given (true)"; |
839 | my $obj = OverloadTest->new(1); |
840 | my $matched; |
841 | given($obj) { |
842 | when ("other arg") {$matched = 1} |
843 | default {$matched = 0} |
844 | } |
0d863452 |
845 | |
02eafbe2 |
846 | is($obj->{called}, 1, "$test: called"); |
847 | ok($matched, "$test: matched"); |
848 | is($obj->{left}, "string value of obj", "$test: left"); |
849 | is($obj->{right}, "other arg", "$test: right"); |
850 | ok(!$obj->{reversed}, "$test: not reversed"); |
851 | } |
852 | |
853 | { |
854 | my $test = "Overloaded obj in given (false)"; |
855 | my $obj = OverloadTest->new(0); |
856 | my $matched; |
857 | given($obj) { |
858 | when ("other arg") {$matched = 1} |
859 | } |
0d863452 |
860 | |
02eafbe2 |
861 | is($obj->{called}, 1, "$test: called"); |
862 | ok(!$matched, "$test: not matched"); |
863 | is($obj->{left}, "string value of obj", "$test: left"); |
864 | is($obj->{right}, "other arg", "$test: right"); |
865 | ok(!$obj->{reversed}, "$test: not reversed"); |
866 | } |
867 | |
868 | { |
869 | my $test = "Overloaded obj in when (true)"; |
870 | my $obj = OverloadTest->new(1); |
871 | my $matched; |
872 | given("topic") { |
873 | when ($obj) {$matched = 1} |
874 | default {$matched = 0} |
875 | } |
0d863452 |
876 | |
02eafbe2 |
877 | is($obj->{called}, 1, "$test: called"); |
878 | ok($matched, "$test: matched"); |
879 | is($obj->{left}, "topic", "$test: left"); |
880 | is($obj->{right}, "string value of obj", "$test: right"); |
881 | ok($obj->{reversed}, "$test: reversed"); |
882 | } |
883 | |
884 | { |
885 | my $test = "Overloaded obj in when (false)"; |
886 | my $obj = OverloadTest->new(0); |
887 | my $matched; |
888 | given("topic") { |
889 | when ($obj) {$matched = 1} |
890 | default {$matched = 0} |
891 | } |
0d863452 |
892 | |
02eafbe2 |
893 | is($obj->{called}, 1, "$test: called"); |
894 | ok(!$matched, "$test: not matched"); |
895 | is($obj->{left}, "topic", "$test: left"); |
896 | is($obj->{right}, "string value of obj", "$test: right"); |
897 | ok($obj->{reversed}, "$test: reversed"); |
898 | } |
0d863452 |
899 | } |
0d863452 |
900 | # Okay, that'll do for now. The intricacies of the smartmatch |
901 | # semantics are tested in t/op/smartmatch.t |
902 | __END__ |