d897157946a2838b5b4a8b7d574e0b2cc5f44520
[perl.git] / t / op / switch.t
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 => 108;
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 {    
61     my $ok;
62     given(3) {
63         when(2) { $ok = 'two'; }
64         when(3) { $ok = 'three'; }
65         when(4) { $ok = 'four'; }
66         default { $ok = 'd'; }
67     }
68     is($ok, 'three', "numeric comparison");
69 }
70
71 {    
72     my $ok;
73     use integer;
74     given(3.14159265) {
75         when(2) { $ok = 'two'; }
76         when(3) { $ok = 'three'; }
77         when(4) { $ok = 'four'; }
78         default { $ok = 'd'; }
79     }
80     is($ok, 'three', "integer comparison");
81 }
82
83 {    
84     my ($ok1, $ok2);
85     given(3) {
86         when(3.1)   { $ok1 = 'n'; }
87         when(3.0)   { $ok1 = 'y'; continue }
88         when("3.0") { $ok2 = 'y'; }
89         default     { $ok2 = 'n'; }
90     }
91     is($ok1, 'y', "more numeric (pt. 1)");
92     is($ok2, 'y', "more numeric (pt. 2)");
93 }
94
95 {
96     my $ok;
97     given("c") {
98         when("b") { $ok = 'B'; }
99         when("c") { $ok = 'C'; }
100         when("d") { $ok = 'D'; }
101         default   { $ok = 'def'; }
102     }
103     is($ok, 'C', "string comparison");
104 }
105
106 {
107     my $ok;
108     given("c") {
109         when("b") { $ok = 'B'; }
110         when("c") { $ok = 'C'; continue }
111         when("c") { $ok = 'CC'; }
112         default   { $ok = 'D'; }
113     }
114     is($ok, 'CC', "simple continue");
115 }
116
117 # Definedness
118 {
119     my $ok = 1;
120     given (0) { when(undef) {$ok = 0} }
121     is($ok, 1, "Given(0) when(undef)");
122 }
123 {
124     my $undef;
125     my $ok = 1;
126     given (0) { when($undef) {$ok = 0} }
127     is($ok, 1, 'Given(0) when($undef)');
128 }
129 {
130     my $undef;
131     my $ok = 0;
132     given (0) { when($undef++) {$ok = 1} }
133     is($ok, 1, "Given(0) when($undef++)");
134 }
135 {
136     my $ok = 1;
137     given (undef) { when(0) {$ok = 0} }
138     is($ok, 1, "Given(undef) when(0)");
139 }
140 {
141     my $undef;
142     my $ok = 1;
143     given ($undef) { when(0) {$ok = 0} }
144     is($ok, 1, 'Given($undef) when(0)');
145 }
146 ########
147 {
148     my $ok = 1;
149     given ("") { when(undef) {$ok = 0} }
150     is($ok, 1, 'Given("") when(undef)');
151 }
152 {
153     my $undef;
154     my $ok = 1;
155     given ("") { when($undef) {$ok = 0} }
156     is($ok, 1, 'Given("") when($undef)');
157 }
158 {
159     my $ok = 1;
160     given (undef) { when("") {$ok = 0} }
161     is($ok, 1, 'Given(undef) when("")');
162 }
163 {
164     my $undef;
165     my $ok = 1;
166     given ($undef) { when("") {$ok = 0} }
167     is($ok, 1, 'Given($undef) when("")');
168 }
169 ########
170 {
171     my $ok = 0;
172     given (undef) { when(undef) {$ok = 1} }
173     is($ok, 1, "Given(undef) when(undef)");
174 }
175 {
176     my $undef;
177     my $ok = 0;
178     given (undef) { when($undef) {$ok = 1} }
179     is($ok, 1, 'Given(undef) when($undef)');
180 }
181 {
182     my $undef;
183     my $ok = 0;
184     given ($undef) { when(undef) {$ok = 1} }
185     is($ok, 1, 'Given($undef) when(undef)');
186 }
187 {
188     my $undef;
189     my $ok = 0;
190     given ($undef) { when($undef) {$ok = 1} }
191     is($ok, 1, 'Given($undef) when($undef)');
192 }
193
194
195 # Regular expressions
196 {
197     my ($ok1, $ok2);
198     given("Hello, world!") {
199         when(/lo/)
200             { $ok1 = 'y'; continue}
201         when(/no/)
202             { $ok1 = 'n'; continue}
203         when(/^(Hello,|Goodbye cruel) world[!.?]/)
204             { $ok2 = 'Y'; continue}
205         when(/^(Hello cruel|Goodbye,) world[!.?]/)
206             { $ok2 = 'n'; continue}
207     }
208     is($ok1, 'y', "regex 1");
209     is($ok2, 'Y', "regex 2");
210 }
211
212 # Comparisons
213 {
214     my $test = "explicit numeric comparison (<)";
215     my $twenty_five = 25;
216     my $ok;
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" }
223     }
224     is($ok, "thirty", $test);
225 }
226
227 {
228     use integer;
229     my $test = "explicit numeric comparison (integer <)";
230     my $twenty_five = 25;
231     my $ok;
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" }
238     }
239     is($ok, "thirty", $test);
240 }
241
242 {
243     my $test = "explicit numeric comparison (<=)";
244     my $twenty_five = 25;
245     my $ok;
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" }
252     }
253     is($ok, "thirty", $test);
254 }
255
256 {
257     use integer;
258     my $test = "explicit numeric comparison (integer <=)";
259     my $twenty_five = 25;
260     my $ok;
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" }
267     }
268     is($ok, "thirty", $test);
269 }
270
271
272 {
273     my $test = "explicit numeric comparison (>)";
274     my $twenty_five = 25;
275     my $ok;
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" }
282     }
283     is($ok, "twenty", $test);
284 }
285
286 {
287     my $test = "explicit numeric comparison (>=)";
288     my $twenty_five = 25;
289     my $ok;
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" }
296     }
297     is($ok, "twenty", $test);
298 }
299
300 {
301     use integer;
302     my $test = "explicit numeric comparison (integer >)";
303     my $twenty_five = 25;
304     my $ok;
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" }
311     }
312     is($ok, "twenty", $test);
313 }
314
315 {
316     use integer;
317     my $test = "explicit numeric comparison (integer >=)";
318     my $twenty_five = 25;
319     my $ok;
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" }
326     }
327     is($ok, "twenty", $test);
328 }
329
330
331 {
332     my $test = "explicit string comparison (lt)";
333     my $twenty_five = "25";
334     my $ok;
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" }
341     }
342     is($ok, "thirty", $test);
343 }
344
345 {
346     my $test = "explicit string comparison (le)";
347     my $twenty_five = "25";
348     my $ok;
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" }
355     }
356     is($ok, "thirty", $test);
357 }
358
359 {
360     my $test = "explicit string comparison (gt)";
361     my $twenty_five = 25;
362     my $ok;
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" }
369     }
370     is($ok, "twenty", $test);
371 }
372
373 {
374     my $test = "explicit string comparison (ge)";
375     my $twenty_five = 25;
376     my $ok;
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" }
383     }
384     is($ok, "twenty", $test);
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;
392     my $ok;
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" }
399     }
400     is($ok, "twenty", $test);
401 }
402
403 # Optimized-away comparisons
404 {
405     my $ok;
406     given(23) {
407         when (2 + 2 == 4) { $ok = 'y'; continue }
408         when (2 + 2 == 5) { $ok = 'n' }
409     }
410     is($ok, 'y', "Optimized-away comparison");
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(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;
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 {
513     my $ok = 0;
514     given("foo") {
515         when((1 == $ok) || "foo") {
516             $ok = 1;
517         }
518     }
519     ok($ok, '((1 == $ok) || "foo") smartmatched');
520 }
521
522
523 # Make sure we aren't invoking the get-magic more than once
524
525 { # A helper class to count the number of accesses.
526     package FetchCounter;
527     sub TIESCALAR {
528         my ($class) = @_;
529         bless {value => undef, count => 0}, $class;
530     }
531     sub STORE {
532         my ($self, $val) = @_;
533         $self->{count} = 0;
534         $self->{value} = $val;
535     }
536     sub FETCH {
537         my ($self) = @_;
538         # Avoid pre/post increment here
539         $self->{count} = 1 + $self->{count};
540         $self->{value};
541     }
542     sub count {
543         my ($self) = @_;
544         $self->{count};
545     }
546 }
547
548 my $f = tie my $v, "FetchCounter";
549
550 {   my $test_name = "Only one FETCH (in given)";
551     my $ok;
552     given($v = 23) {
553         when(undef) {}
554         when(sub{0}->()) {}
555         when(21) {}
556         when("22") {}
557         when(23) {$ok = 1}
558         when(/24/) {$ok = 0}
559     }
560     is($ok, 1, "precheck: $test_name");
561     is($f->count(), 1, $test_name);
562 }
563
564 {   my $test_name = "Only one FETCH (numeric when)";
565     my $ok;
566     $v = 23;
567     is($f->count(), 0, "Sanity check: $test_name");
568     given(23) {
569         when(undef) {}
570         when(sub{0}->()) {}
571         when(21) {}
572         when("22") {}
573         when($v) {$ok = 1}
574         when(/24/) {$ok = 0}
575     }
576     is($ok, 1, "precheck: $test_name");
577     is($f->count(), 1, $test_name);
578 }
579
580 {   my $test_name = "Only one FETCH (string when)";
581     my $ok;
582     $v = "23";
583     is($f->count(), 0, "Sanity check: $test_name");
584     given("23") {
585         when(undef) {}
586         when(sub{0}->()) {}
587         when("21") {}
588         when("22") {}
589         when($v) {$ok = 1}
590         when(/24/) {$ok = 0}
591     }
592     is($ok, 1, "precheck: $test_name");
593     is($f->count(), 1, $test_name);
594 }
595
596 {   my $test_name = "Only one FETCH (undef)";
597     my $ok;
598     $v = undef;
599     is($f->count(), 0, "Sanity check: $test_name");
600     given(my $undef) {
601         when(sub{0}->()) {}
602         when("21")  {}
603         when("22")  {}
604         when($v)    {$ok = 1}
605         when(undef) {$ok = 0}
606     }
607     is($ok, 1, "precheck: $test_name");
608     is($f->count(), 1, $test_name);
609 }
610
611 # Loop topicalizer
612 {
613     my $first = 1;
614     for (1, "two") {
615         when ("two") {
616             is($first, 0, "Loop: second");
617             eval {break};
618             like($@, qr/^Can't "break" in a loop topicalizer/,
619                 q{Can't "break" in a loop topicalizer});
620         }
621         when (1) {
622             is($first, 1, "Loop: first");
623             $first = 0;
624             # Implicit break is okay
625         }
626     }
627 }
628
629 {
630     my $first = 1;
631     for $_ (1, "two") {
632         when ("two") {
633             is($first, 0, "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, "Explicit \$_: first");
640             $first = 0;
641             # Implicit break is okay
642         }
643     }
644 }
645
646 {
647     my $first = 1;
648     my $_;
649     for (1, "two") {
650         when ("two") {
651             is($first, 0, "Implicitly lexical loop: second");
652             eval {break};
653             like($@, qr/^Can't "break" in a loop topicalizer/,
654                 q{Can't "break" in a loop topicalizer});
655         }
656         when (1) {
657             is($first, 1, "Implicitly lexical loop: first");
658             $first = 0;
659             # Implicit break is okay
660         }
661     }
662 }
663
664 {
665     my $first = 1;
666     my $_;
667     for $_ (1, "two") {
668         when ("two") {
669             is($first, 0, "Implicitly lexical, explicit \$_: second");
670             eval {break};
671             like($@, qr/^Can't "break" in a loop topicalizer/,
672                 q{Can't "break" in a loop topicalizer});
673         }
674         when (1) {
675             is($first, 1, "Implicitly lexical, explicit \$_: first");
676             $first = 0;
677             # Implicit break is okay
678         }
679     }
680 }
681
682 {
683     my $first = 1;
684     for my $_ (1, "two") {
685         when ("two") {
686             is($first, 0, "Lexical loop: second");
687             eval {break};
688             like($@, qr/^Can't "break" in a loop topicalizer/,
689                 q{Can't "break" in a loop topicalizer});
690         }
691         when (1) {
692             is($first, 1, "Lecical loop: first");
693             $first = 0;
694             # Implicit break is okay
695         }
696     }
697 }
698
699
700 # Code references
701 {
702     no warnings "redefine";
703     my $called_foo = 0;
704     sub foo {$called_foo = 1}
705     my $called_bar = 0;
706     sub bar {$called_bar = 1}
707     my ($matched_foo, $matched_bar) = (0, 0);
708     given(\&foo) {
709         when(\&bar) {$matched_bar = 1}
710         when(\&foo) {$matched_foo = 1}
711     }
712     is($called_foo, 0,  "Code ref comparison: foo not called");
713     is($called_bar, 0,  "Code ref comparison: bar not called");
714     is($matched_bar, 0, "Code ref didn't match different one");
715     is($matched_foo, 1, "Code ref did match itself");
716 }
717
718 sub contains_x {
719     my $x = shift;
720     return ($x =~ /x/);
721 }
722 {
723     my ($ok1, $ok2) = (0,0);
724     given("foxy!") {
725         when(contains_x($_))
726             { $ok1 = 1; continue }
727         when(\&contains_x)
728             { $ok2 = 1; continue }
729     }
730     is($ok1, 1, "Calling sub directly (true)");
731     is($ok2, 1, "Calling sub indirectly (true)");
732
733     given("foggy") {
734         when(contains_x($_))
735             { $ok1 = 2; continue }
736         when(\&contains_x)
737             { $ok2 = 2; continue }
738     }
739     is($ok1, 1, "Calling sub directly (false)");
740     is($ok2, 1, "Calling sub indirectly (false)");
741 }
742
743 # Test overloading
744 { package OverloadTest;
745
746     use overload '""' => sub{"string value of obj"};
747
748     use overload "~~" => sub {
749         my ($self, $other, $reversed) = @_;
750         if ($reversed) {
751             $self->{left}  = $other;
752             $self->{right} = $self;
753             $self->{reversed} = 1;
754         } else {
755             $self->{left}  = $self;
756             $self->{right} = $other;
757             $self->{reversed} = 0;
758         }
759         $self->{called} = 1;
760         return $self->{retval};
761     };
762     
763     sub new {
764         my ($pkg, $retval) = @_;
765         bless {
766             called => 0,
767             retval => $retval,
768         }, $pkg;
769     }
770 }
771
772 {
773     my $test = "Overloaded obj in given (true)";
774     my $obj = OverloadTest->new(1);
775     my $matched;
776     given($obj) {
777         when ("other arg") {$matched = 1}
778         default {$matched = 0}
779     }
780     
781     is($obj->{called},  1, "$test: called");
782     ok($matched, "$test: matched");
783     is($obj->{left}, "string value of obj", "$test: left");
784     is($obj->{right}, "other arg", "$test: right");
785     ok(!$obj->{reversed}, "$test: not reversed");
786 }
787
788 {
789     my $test = "Overloaded obj in given (false)";
790     my $obj = OverloadTest->new(0);
791     my $matched;
792     given($obj) {
793         when ("other arg") {$matched = 1}
794     }
795     
796     is($obj->{called},  1, "$test: called");
797     ok(!$matched, "$test: not matched");
798     is($obj->{left}, "string value of obj", "$test: left");
799     is($obj->{right}, "other arg", "$test: right");
800     ok(!$obj->{reversed}, "$test: not reversed");
801 }
802
803 {
804     my $test = "Overloaded obj in when (true)";
805     my $obj = OverloadTest->new(1);
806     my $matched;
807     given("topic") {
808         when ($obj) {$matched = 1}
809         default {$matched = 0}
810     }
811     
812     is($obj->{called},  1, "$test: called");
813     ok($matched, "$test: matched");
814     is($obj->{left}, "topic", "$test: left");
815     is($obj->{right}, "string value of obj", "$test: right");
816     ok($obj->{reversed}, "$test: reversed");
817 }
818
819 {
820     my $test = "Overloaded obj in when (false)";
821     my $obj = OverloadTest->new(0);
822     my $matched;
823     given("topic") {
824         when ($obj) {$matched = 1}
825         default {$matched = 0}
826     }
827     
828     is($obj->{called}, 1, "$test: called");
829     ok(!$matched, "$test: not matched");
830     is($obj->{left}, "topic", "$test: left");
831     is($obj->{right}, "string value of obj", "$test: right");
832     ok($obj->{reversed}, "$test: reversed");
833 }
834
835 # Okay, that'll do for now. The intricacies of the smartmatch
836 # semantics are tested in t/op/smartmatch.t
837 __END__