11 use Test::More tests => 113;
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.
19 no warnings "numeric";
22 like($@, qr/^Can't "continue" outside/, "continue outside");
25 like($@, qr/^Can't "break" outside/, "break outside");
31 given(my $x = "bar") {
32 is($x, "bar", "given scope starts");
34 is($x, "foo", "given scope ends");
39 given(my $x = "foo") {
40 when(be_true(my $x = "bar")) {
41 is($x, "bar", "given scope starts");
43 is($x, "foo", "given scope ends");
47 given("inside") { check_outside1() }
48 sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
52 given("inside") { check_outside2() }
54 is($_, "outside", "\$_ lexically scoped (lexical \$_)")
58 # Basic string/numeric comparisons and control flow
63 when(2) { $ok = 'two'; }
64 when(3) { $ok = 'three'; }
65 when(4) { $ok = 'four'; }
66 default { $ok = 'd'; }
68 is($ok, 'three', "numeric comparison");
75 when(2) { $ok = 'two'; }
76 when(3) { $ok = 'three'; }
77 when(4) { $ok = 'four'; }
78 default { $ok = 'd'; }
80 is($ok, 'three', "integer comparison");
86 when(3.1) { $ok1 = 'n'; }
87 when(3.0) { $ok1 = 'y'; continue }
88 when("3.0") { $ok2 = 'y'; }
89 default { $ok2 = 'n'; }
91 is($ok1, 'y', "more numeric (pt. 1)");
92 is($ok2, 'y', "more numeric (pt. 2)");
98 when("b") { $ok = 'B'; }
99 when("c") { $ok = 'C'; }
100 when("d") { $ok = 'D'; }
101 default { $ok = 'def'; }
103 is($ok, 'C', "string comparison");
109 when("b") { $ok = 'B'; }
110 when("c") { $ok = 'C'; continue }
111 when("c") { $ok = 'CC'; }
112 default { $ok = 'D'; }
114 is($ok, 'CC', "simple continue");
120 given (0) { when(undef) {$ok = 0} }
121 is($ok, 1, "Given(0) when(undef)");
126 given (0) { when($undef) {$ok = 0} }
127 is($ok, 1, 'Given(0) when($undef)');
132 given (0) { when($undef++) {$ok = 1} }
133 is($ok, 1, "Given(0) when($undef++)");
137 given (undef) { when(0) {$ok = 0} }
138 is($ok, 1, "Given(undef) when(0)");
143 given ($undef) { when(0) {$ok = 0} }
144 is($ok, 1, 'Given($undef) when(0)');
149 given ("") { when(undef) {$ok = 0} }
150 is($ok, 1, 'Given("") when(undef)');
155 given ("") { when($undef) {$ok = 0} }
156 is($ok, 1, 'Given("") when($undef)');
160 given (undef) { when("") {$ok = 0} }
161 is($ok, 1, 'Given(undef) when("")');
166 given ($undef) { when("") {$ok = 0} }
167 is($ok, 1, 'Given($undef) when("")');
172 given (undef) { when(undef) {$ok = 1} }
173 is($ok, 1, "Given(undef) when(undef)");
178 given (undef) { when($undef) {$ok = 1} }
179 is($ok, 1, 'Given(undef) when($undef)');
184 given ($undef) { when(undef) {$ok = 1} }
185 is($ok, 1, 'Given($undef) when(undef)');
190 given ($undef) { when($undef) {$ok = 1} }
191 is($ok, 1, 'Given($undef) when($undef)');
195 # Regular expressions
198 given("Hello, world!") {
200 { $ok1 = 'y'; continue}
202 { $ok1 = 'n'; continue}
203 when(/^(Hello,|Goodbye cruel) world[!.?]/)
204 { $ok2 = 'Y'; continue}
205 when(/^(Hello cruel|Goodbye,) world[!.?]/)
206 { $ok2 = 'n'; continue}
208 is($ok1, 'y', "regex 1");
209 is($ok2, 'Y', "regex 2");
214 my $test = "explicit numeric comparison (<)";
215 my $twenty_five = 25;
217 given($twenty_five) {
218 when ($_ < 10) { $ok = "ten" }
219 when ($_ < 20) { $ok = "twenty" }
220 when ($_ < 30) { $ok = "thirty" }
221 when ($_ < 40) { $ok = "forty" }
222 default { $ok = "default" }
224 is($ok, "thirty", $test);
229 my $test = "explicit numeric comparison (integer <)";
230 my $twenty_five = 25;
232 given($twenty_five) {
233 when ($_ < 10) { $ok = "ten" }
234 when ($_ < 20) { $ok = "twenty" }
235 when ($_ < 30) { $ok = "thirty" }
236 when ($_ < 40) { $ok = "forty" }
237 default { $ok = "default" }
239 is($ok, "thirty", $test);
243 my $test = "explicit numeric comparison (<=)";
244 my $twenty_five = 25;
246 given($twenty_five) {
247 when ($_ <= 10) { $ok = "ten" }
248 when ($_ <= 20) { $ok = "twenty" }
249 when ($_ <= 30) { $ok = "thirty" }
250 when ($_ <= 40) { $ok = "forty" }
251 default { $ok = "default" }
253 is($ok, "thirty", $test);
258 my $test = "explicit numeric comparison (integer <=)";
259 my $twenty_five = 25;
261 given($twenty_five) {
262 when ($_ <= 10) { $ok = "ten" }
263 when ($_ <= 20) { $ok = "twenty" }
264 when ($_ <= 30) { $ok = "thirty" }
265 when ($_ <= 40) { $ok = "forty" }
266 default { $ok = "default" }
268 is($ok, "thirty", $test);
273 my $test = "explicit numeric comparison (>)";
274 my $twenty_five = 25;
276 given($twenty_five) {
277 when ($_ > 40) { $ok = "forty" }
278 when ($_ > 30) { $ok = "thirty" }
279 when ($_ > 20) { $ok = "twenty" }
280 when ($_ > 10) { $ok = "ten" }
281 default { $ok = "default" }
283 is($ok, "twenty", $test);
287 my $test = "explicit numeric comparison (>=)";
288 my $twenty_five = 25;
290 given($twenty_five) {
291 when ($_ >= 40) { $ok = "forty" }
292 when ($_ >= 30) { $ok = "thirty" }
293 when ($_ >= 20) { $ok = "twenty" }
294 when ($_ >= 10) { $ok = "ten" }
295 default { $ok = "default" }
297 is($ok, "twenty", $test);
302 my $test = "explicit numeric comparison (integer >)";
303 my $twenty_five = 25;
305 given($twenty_five) {
306 when ($_ > 40) { $ok = "forty" }
307 when ($_ > 30) { $ok = "thirty" }
308 when ($_ > 20) { $ok = "twenty" }
309 when ($_ > 10) { $ok = "ten" }
310 default { $ok = "default" }
312 is($ok, "twenty", $test);
317 my $test = "explicit numeric comparison (integer >=)";
318 my $twenty_five = 25;
320 given($twenty_five) {
321 when ($_ >= 40) { $ok = "forty" }
322 when ($_ >= 30) { $ok = "thirty" }
323 when ($_ >= 20) { $ok = "twenty" }
324 when ($_ >= 10) { $ok = "ten" }
325 default { $ok = "default" }
327 is($ok, "twenty", $test);
332 my $test = "explicit string comparison (lt)";
333 my $twenty_five = "25";
335 given($twenty_five) {
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" }
342 is($ok, "thirty", $test);
346 my $test = "explicit string comparison (le)";
347 my $twenty_five = "25";
349 given($twenty_five) {
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" }
356 is($ok, "thirty", $test);
360 my $test = "explicit string comparison (gt)";
361 my $twenty_five = 25;
363 given($twenty_five) {
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" }
370 is($ok, "twenty", $test);
374 my $test = "explicit string comparison (ge)";
375 my $twenty_five = 25;
377 given($twenty_five) {
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" }
384 is($ok, "twenty", $test);
387 # Make sure it still works with a lexical $_:
390 my $test = "explicit comparison with lexical \$_";
391 my $twenty_five = 25;
393 given($twenty_five) {
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" }
400 is($ok, "twenty", $test);
403 # Optimized-away comparisons
407 when (2 + 2 == 4) { $ok = 'y'; continue }
408 when (2 + 2 == 5) { $ok = 'n' }
410 is($ok, 'y', "Optimized-away comparison");
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
419 my ($ok_d, $ok_f, $ok_r);
421 when(-d) {$ok_d = 1; continue}
422 when(!-f) {$ok_f = 1; continue}
423 when(-r) {$ok_r = 1; continue}
425 ok($ok_d, "Filetest -d");
426 ok($ok_f, "Filetest -f");
427 ok($ok_r, "Filetest -r");
430 # Sub and method calls
435 when(notfoo()) {$ok = 1}
437 ok($ok, "Sub call acts as boolean")
443 when(main->notfoo()) {$ok = 1}
445 ok($ok, "Class-method call acts as boolean")
452 when($obj->notfoo()) {$ok = 1}
454 ok($ok, "Object-method call acts as boolean")
457 # Other things that should not be smart matched
461 when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
465 ok($ok, "bool not smartmatches");
475 ok($ok, "eof() not smartmatched");
480 my %foo = ("bar", 0);
482 when(exists $foo{bar}) {
486 ok($ok, "exists() not smartmatched");
496 ok($ok, "defined() not smartmatched");
502 when((1 == 1) && "bar") {
505 when((1 == 1) && $_ eq "foo") {
509 is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
514 for my $l qw(a b c d) {
516 when ($_ eq "b" ... $_ eq "c") { $n = 1 }
519 ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
526 when((1 == $ok) || "foo") {
530 ok($ok, '((1 == $ok) || "foo") smartmatched');
536 when((1 == $ok || undef) // "foo") {
540 ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
543 # Make sure we aren't invoking the get-magic more than once
545 { # A helper class to count the number of accesses.
546 package FetchCounter;
549 bless {value => undef, count => 0}, $class;
552 my ($self, $val) = @_;
554 $self->{value} = $val;
558 # Avoid pre/post increment here
559 $self->{count} = 1 + $self->{count};
568 my $f = tie my $v, "FetchCounter";
570 { my $test_name = "Only one FETCH (in given)";
580 is($ok, 1, "precheck: $test_name");
581 is($f->count(), 1, $test_name);
584 { my $test_name = "Only one FETCH (numeric when)";
587 is($f->count(), 0, "Sanity check: $test_name");
596 is($ok, 1, "precheck: $test_name");
597 is($f->count(), 1, $test_name);
600 { my $test_name = "Only one FETCH (string when)";
603 is($f->count(), 0, "Sanity check: $test_name");
612 is($ok, 1, "precheck: $test_name");
613 is($f->count(), 1, $test_name);
616 { my $test_name = "Only one FETCH (undef)";
619 is($f->count(), 0, "Sanity check: $test_name");
625 when(undef) {$ok = 0}
627 is($ok, 1, "precheck: $test_name");
628 is($f->count(), 1, $test_name);
636 is($first, 0, "Loop: second");
638 like($@, qr/^Can't "break" in a loop topicalizer/,
639 q{Can't "break" in a loop topicalizer});
642 is($first, 1, "Loop: first");
644 # Implicit break is okay
653 is($first, 0, "Explicit \$_: second");
655 like($@, qr/^Can't "break" in a loop topicalizer/,
656 q{Can't "break" in a loop topicalizer});
659 is($first, 1, "Explicit \$_: first");
661 # Implicit break is okay
671 is($first, 0, "Implicitly lexical loop: second");
673 like($@, qr/^Can't "break" in a loop topicalizer/,
674 q{Can't "break" in a loop topicalizer});
677 is($first, 1, "Implicitly lexical loop: first");
679 # Implicit break is okay
689 is($first, 0, "Implicitly lexical, explicit \$_: second");
691 like($@, qr/^Can't "break" in a loop topicalizer/,
692 q{Can't "break" in a loop topicalizer});
695 is($first, 1, "Implicitly lexical, explicit \$_: first");
697 # Implicit break is okay
704 for my $_ (1, "two") {
706 is($first, 0, "Lexical loop: second");
708 like($@, qr/^Can't "break" in a loop topicalizer/,
709 q{Can't "break" in a loop topicalizer});
712 is($first, 1, "Lexical loop: first");
714 # Implicit break is okay
722 no warnings "redefine";
724 sub foo {$called_foo = 1; "@_" eq "foo"}
726 sub bar {$called_bar = 1; "@_" eq "bar"}
727 my ($matched_foo, $matched_bar) = (0, 0);
729 when(\&bar) {$matched_bar = 1}
730 when(\&foo) {$matched_foo = 1}
732 is($called_foo, 1, "foo() was called");
733 is($called_bar, 1, "bar() was called");
734 is($matched_bar, 0, "bar didn't match");
735 is($matched_foo, 1, "foo did match");
743 my ($ok1, $ok2) = (0,0);
746 { $ok1 = 1; continue }
748 { $ok2 = 1; continue }
750 is($ok1, 1, "Calling sub directly (true)");
751 is($ok2, 1, "Calling sub indirectly (true)");
755 { $ok1 = 2; continue }
757 { $ok2 = 2; continue }
759 is($ok1, 1, "Calling sub directly (false)");
760 is($ok2, 1, "Calling sub indirectly (false)");
764 skip "Scalar/Util.pm not yet available", 20
765 unless -r "$INC[0]/Scalar/Util.pm";
767 { package OverloadTest;
769 use overload '""' => sub{"string value of obj"};
771 use overload "~~" => sub {
772 my ($self, $other, $reversed) = @_;
774 $self->{left} = $other;
775 $self->{right} = $self;
776 $self->{reversed} = 1;
778 $self->{left} = $self;
779 $self->{right} = $other;
780 $self->{reversed} = 0;
783 return $self->{retval};
787 my ($pkg, $retval) = @_;
796 my $test = "Overloaded obj in given (true)";
797 my $obj = OverloadTest->new(1);
800 when ("other arg") {$matched = 1}
801 default {$matched = 0}
804 is($obj->{called}, 1, "$test: called");
805 ok($matched, "$test: matched");
806 is($obj->{left}, "string value of obj", "$test: left");
807 is($obj->{right}, "other arg", "$test: right");
808 ok(!$obj->{reversed}, "$test: not reversed");
812 my $test = "Overloaded obj in given (false)";
813 my $obj = OverloadTest->new(0);
816 when ("other arg") {$matched = 1}
819 is($obj->{called}, 1, "$test: called");
820 ok(!$matched, "$test: not matched");
821 is($obj->{left}, "string value of obj", "$test: left");
822 is($obj->{right}, "other arg", "$test: right");
823 ok(!$obj->{reversed}, "$test: not reversed");
827 my $test = "Overloaded obj in when (true)";
828 my $obj = OverloadTest->new(1);
831 when ($obj) {$matched = 1}
832 default {$matched = 0}
835 is($obj->{called}, 1, "$test: called");
836 ok($matched, "$test: matched");
837 is($obj->{left}, "topic", "$test: left");
838 is($obj->{right}, "string value of obj", "$test: right");
839 ok($obj->{reversed}, "$test: reversed");
843 my $test = "Overloaded obj in when (false)";
844 my $obj = OverloadTest->new(0);
847 when ($obj) {$matched = 1}
848 default {$matched = 0}
851 is($obj->{called}, 1, "$test: called");
852 ok(!$matched, "$test: not matched");
853 is($obj->{left}, "topic", "$test: left");
854 is($obj->{right}, "string value of obj", "$test: right");
855 ok($obj->{reversed}, "$test: reversed");
858 # Okay, that'll do for now. The intricacies of the smartmatch
859 # semantics are tested in t/op/smartmatch.t