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