11 use Test::More tests => 107;
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
68 ok($ok, "numeric comparison");
80 ok($ok, "integer comparison");
84 my ($ok1, $ok2) = (0, 0);
86 when(3.1) { $ok1 = 0; }
87 when(3.0) { $ok1 = 1; continue }
88 when("3.0") { $ok2 = 1; }
91 ok($ok1, "more numeric (pt. 1)");
92 ok($ok2, "more numeric (pt. 2)");
98 when("b") { $ok = 0; }
99 when("c") { $ok = 1; }
100 when("d") { $ok = 0; }
103 ok($ok, "string comparison");
109 when("b") { $ok = 0; }
110 when("c") { $ok = 0; continue }
111 when("c") { $ok = 1; }
114 ok($ok, "simple continue");
120 given (0) { when(undef) {$ok = 0} }
121 ok($ok, "Given(0) when(undef)");
126 given (0) { when($undef) {$ok = 0} }
127 ok($ok, 'Given(0) when($undef)');
132 given (0) { when($undef++) {$ok = 1} }
133 ok($ok, "Given(0) when($undef++)");
137 given (undef) { when(0) {$ok = 0} }
138 ok($ok, "Given(undef) when(0)");
143 given ($undef) { when(0) {$ok = 0} }
144 ok($ok, 'Given($undef) when(0)');
149 given ("") { when(undef) {$ok = 0} }
150 ok($ok, 'Given("") when(undef)');
155 given ("") { when($undef) {$ok = 0} }
156 ok($ok, 'Given("") when($undef)');
160 given (undef) { when("") {$ok = 0} }
161 ok($ok, 'Given(undef) when("")');
166 given ($undef) { when("") {$ok = 0} }
167 ok($ok, 'Given($undef) when("")');
172 given (undef) { when(undef) {$ok = 1} }
173 ok($ok, "Given(undef) when(undef)");
178 given (undef) { when($undef) {$ok = 1} }
179 ok($ok, 'Given(undef) when($undef)');
184 given ($undef) { when(undef) {$ok = 1} }
185 ok($ok, 'Given($undef) when(undef)');
190 given ($undef) { when($undef) {$ok = 1} }
191 ok($ok, 'Given($undef) when($undef)');
195 # Regular expressions
198 given("Hello, world!") {
200 { $ok1 = 1; continue}
202 { $ok1 = 0; continue}
203 when(/^(Hello,|Goodbye cruel) world[!.?]/)
204 { $ok2 = 1; continue}
205 when(/^(Hello cruel|Goodbye,) world[!.?]/)
206 { $ok2 = 0; continue}
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) }
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) }
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) }
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) }
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) }
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) }
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) }
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) }
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) }
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) }
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) }
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) }
363 # Make sure it still works with a lexical $_:
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) }
377 # Optimized-away comparisons
381 when (2 + 2 == 4) { $ok = 1; continue }
382 when (2 + 2 == 5) { $ok = 0 }
384 ok($ok, "Optimized-away comparison");
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
393 my ($ok_d, $ok_f, $ok_r);
395 when(-d) {$ok_d = 1; continue}
396 when(!-f) {$ok_f = 1; continue}
397 when(-r) {$ok_r = 1; continue}
399 ok($ok_d, "Filetest -d");
400 ok($ok_f, "Filetest -f");
401 ok($ok_r, "Filetest -r");
404 # Sub and method calls
409 when(bar()) {$ok = 1}
411 ok($ok, "Sub call acts as boolean")
417 when(main->bar()) {$ok = 1}
419 ok($ok, "Class-method call acts as boolean")
426 when($obj->bar()) {$ok = 1}
428 ok($ok, "Object-method call acts as boolean")
431 # Other things that should not be smart matched
439 ok($ok, "eof() not smartmatched");
444 my %foo = ("bar", 0);
446 when(exists $foo{bar}) {
450 ok($ok, "exists() not smartmatched");
460 ok($ok, "defined() not smartmatched");
466 when((1 == 1) && "bar") {
469 when((1 == 1) && $_ eq "foo") {
473 is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
479 when((1 == $ok) || "foo") {
483 ok($ok, '((1 == $ok) || "foo") not smartmatched');
487 # Make sure we aren't invoking the get-magic more than once
489 { # A helper class to count the number of accesses.
490 package FetchCounter;
493 bless {value => undef, count => 0}, $class;
496 my ($self, $val) = @_;
498 $self->{value} = $val;
502 # Avoid pre/post increment here
503 $self->{count} = 1 + $self->{count};
512 my $f = tie my $v, "FetchCounter";
514 { my $test_name = "Only one FETCH (in given)";
524 ok($ok, "precheck: $test_name");
525 is($f->count(), 1, $test_name);
528 { my $test_name = "Only one FETCH (numeric when)";
531 is($f->count(), 0, "Sanity check: $test_name");
540 ok($ok, "precheck: $test_name");
541 is($f->count(), 1, $test_name);
544 { my $test_name = "Only one FETCH (string when)";
547 is($f->count(), 0, "Sanity check: $test_name");
556 ok($ok, "precheck: $test_name");
557 is($f->count(), 1, $test_name);
560 { my $test_name = "Only one FETCH (undef)";
563 is($f->count(), 0, "Sanity check: $test_name");
569 when(undef) {$ok = 0}
571 ok($ok, "precheck: $test_name");
572 is($f->count(), 1, $test_name);
580 is($first, 0, "Loop: second");
582 like($@, qr/^Can't "break" in a loop topicalizer/,
583 q{Can't "break" in a loop topicalizer});
586 is($first, 1, "Loop: first");
588 # Implicit break is okay
597 is($first, 0, "Explicit \$_: second");
599 like($@, qr/^Can't "break" in a loop topicalizer/,
600 q{Can't "break" in a loop topicalizer});
603 is($first, 1, "Explicit \$_: first");
605 # Implicit break is okay
615 is($first, 0, "Implicitly lexical loop: second");
617 like($@, qr/^Can't "break" in a loop topicalizer/,
618 q{Can't "break" in a loop topicalizer});
621 is($first, 1, "Implicitly lexical loop: first");
623 # Implicit break is okay
633 is($first, 0, "Implicitly lexical, explicit \$_: second");
635 like($@, qr/^Can't "break" in a loop topicalizer/,
636 q{Can't "break" in a loop topicalizer});
639 is($first, 1, "Implicitly lexical, explicit \$_: first");
641 # Implicit break is okay
648 for my $_ (1, "two") {
650 is($first, 0, "Lexical loop: second");
652 like($@, qr/^Can't "break" in a loop topicalizer/,
653 q{Can't "break" in a loop topicalizer});
656 is($first, 1, "Lecical loop: first");
658 # Implicit break is okay
666 no warnings "redefine";
668 sub foo {$called_foo = 1}
670 sub bar {$called_bar = 1}
671 my ($matched_foo, $matched_bar) = (0, 0);
673 when(\&bar) {$matched_bar = 1}
674 when(\&foo) {$matched_foo = 1}
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");
687 my ($ok1, $ok2) = (0,0);
690 { $ok1 = 1; continue }
692 { $ok2 = 1; continue }
694 is($ok1, 1, "Calling sub directly (true)");
695 is($ok2, 1, "Calling sub indirectly (true)");
699 { $ok1 = 2; continue }
701 { $ok2 = 2; continue }
703 is($ok1, 1, "Calling sub directly (false)");
704 is($ok2, 1, "Calling sub indirectly (false)");
708 { package OverloadTest;
710 use overload '""' => sub{"string value of obj"};
712 use overload "~~" => sub {
713 my ($self, $other, $reversed) = @_;
715 $self->{left} = $other;
716 $self->{right} = $self;
717 $self->{reversed} = 1;
719 $self->{left} = $self;
720 $self->{right} = $other;
721 $self->{reversed} = 0;
724 return $self->{retval};
728 my ($pkg, $retval) = @_;
737 my $test = "Overloaded obj in given (true)";
738 my $obj = OverloadTest->new(1);
741 when ("other arg") {$matched = 1}
742 default {$matched = 0}
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");
753 my $test = "Overloaded obj in given (false)";
754 my $obj = OverloadTest->new(0);
757 when ("other arg") {$matched = 1}
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");
768 my $test = "Overloaded obj in when (true)";
769 my $obj = OverloadTest->new(1);
772 when ($obj) {$matched = 1}
773 default {$matched = 0}
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");
784 my $test = "Overloaded obj in when (false)";
785 my $obj = OverloadTest->new(0);
788 when ($obj) {$matched = 1}
789 default {$matched = 0}
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");
799 # Okay, that'll do for now. The intricacies of the smartmatch
800 # semantics are tested in t/op/smartmatch.t