Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.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 => 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
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(0) {
461         when(eof(DATA)) {
462             $ok = 1;
463         }
464     }
465     ok($ok, "eof() not smartmatched");
466 }
467
468 {
469     my $ok = 0;
470     my %foo = ("bar", 0);
471     given(0) {
472         when(exists $foo{bar}) {
473             $ok = 1;
474         }
475     }
476     ok($ok, "exists() not smartmatched");
477 }
478
479 {
480     my $ok = 0;
481     given(0) {
482         when(defined $ok) {
483             $ok = 1;
484         }
485     }
486     ok($ok, "defined() not smartmatched");
487 }
488
489 {
490     my $ok = 1;
491     given("foo") {
492         when((1 == 1) && "bar") {
493             $ok = 0;
494         }
495         when((1 == 1) && $_ eq "foo") {
496             $ok = 2;
497         }
498     }
499     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
500 }
501
502 {
503     my $ok = 1;
504     given(0) {
505         when((1 == $ok) || "foo") {
506             $ok = 0;
507         }
508     }
509     ok($ok, '((1 == $ok) || "foo") not smartmatched');
510 }
511
512
513 # Make sure we aren't invoking the get-magic more than once
514
515 { # A helper class to count the number of accesses.
516     package FetchCounter;
517     sub TIESCALAR {
518         my ($class) = @_;
519         bless {value => undef, count => 0}, $class;
520     }
521     sub STORE {
522         my ($self, $val) = @_;
523         $self->{count} = 0;
524         $self->{value} = $val;
525     }
526     sub FETCH {
527         my ($self) = @_;
528         # Avoid pre/post increment here
529         $self->{count} = 1 + $self->{count};
530         $self->{value};
531     }
532     sub count {
533         my ($self) = @_;
534         $self->{count};
535     }
536 }
537
538 my $f = tie my $v, "FetchCounter";
539
540 {   my $test_name = "Only one FETCH (in given)";
541     my $ok;
542     given($v = 23) {
543         when(undef) {}
544         when(sub{0}->()) {}
545         when(21) {}
546         when("22") {}
547         when(23) {$ok = 1}
548         when(/24/) {$ok = 0}
549     }
550     is($ok, 1, "precheck: $test_name");
551     is($f->count(), 1, $test_name);
552 }
553
554 {   my $test_name = "Only one FETCH (numeric when)";
555     my $ok;
556     $v = 23;
557     is($f->count(), 0, "Sanity check: $test_name");
558     given(23) {
559         when(undef) {}
560         when(sub{0}->()) {}
561         when(21) {}
562         when("22") {}
563         when($v) {$ok = 1}
564         when(/24/) {$ok = 0}
565     }
566     is($ok, 1, "precheck: $test_name");
567     is($f->count(), 1, $test_name);
568 }
569
570 {   my $test_name = "Only one FETCH (string when)";
571     my $ok;
572     $v = "23";
573     is($f->count(), 0, "Sanity check: $test_name");
574     given("23") {
575         when(undef) {}
576         when(sub{0}->()) {}
577         when("21") {}
578         when("22") {}
579         when($v) {$ok = 1}
580         when(/24/) {$ok = 0}
581     }
582     is($ok, 1, "precheck: $test_name");
583     is($f->count(), 1, $test_name);
584 }
585
586 {   my $test_name = "Only one FETCH (undef)";
587     my $ok;
588     $v = undef;
589     is($f->count(), 0, "Sanity check: $test_name");
590     given(my $undef) {
591         when(sub{0}->()) {}
592         when("21")  {}
593         when("22")  {}
594         when($v)    {$ok = 1}
595         when(undef) {$ok = 0}
596     }
597     is($ok, 1, "precheck: $test_name");
598     is($f->count(), 1, $test_name);
599 }
600
601 # Loop topicalizer
602 {
603     my $first = 1;
604     for (1, "two") {
605         when ("two") {
606             is($first, 0, "Loop: second");
607             eval {break};
608             like($@, qr/^Can't "break" in a loop topicalizer/,
609                 q{Can't "break" in a loop topicalizer});
610         }
611         when (1) {
612             is($first, 1, "Loop: first");
613             $first = 0;
614             # Implicit break is okay
615         }
616     }
617 }
618
619 {
620     my $first = 1;
621     for $_ (1, "two") {
622         when ("two") {
623             is($first, 0, "Explicit \$_: second");
624             eval {break};
625             like($@, qr/^Can't "break" in a loop topicalizer/,
626                 q{Can't "break" in a loop topicalizer});
627         }
628         when (1) {
629             is($first, 1, "Explicit \$_: first");
630             $first = 0;
631             # Implicit break is okay
632         }
633     }
634 }
635
636 {
637     my $first = 1;
638     my $_;
639     for (1, "two") {
640         when ("two") {
641             is($first, 0, "Implicitly lexical loop: second");
642             eval {break};
643             like($@, qr/^Can't "break" in a loop topicalizer/,
644                 q{Can't "break" in a loop topicalizer});
645         }
646         when (1) {
647             is($first, 1, "Implicitly lexical loop: first");
648             $first = 0;
649             # Implicit break is okay
650         }
651     }
652 }
653
654 {
655     my $first = 1;
656     my $_;
657     for $_ (1, "two") {
658         when ("two") {
659             is($first, 0, "Implicitly lexical, explicit \$_: second");
660             eval {break};
661             like($@, qr/^Can't "break" in a loop topicalizer/,
662                 q{Can't "break" in a loop topicalizer});
663         }
664         when (1) {
665             is($first, 1, "Implicitly lexical, explicit \$_: first");
666             $first = 0;
667             # Implicit break is okay
668         }
669     }
670 }
671
672 {
673     my $first = 1;
674     for my $_ (1, "two") {
675         when ("two") {
676             is($first, 0, "Lexical loop: second");
677             eval {break};
678             like($@, qr/^Can't "break" in a loop topicalizer/,
679                 q{Can't "break" in a loop topicalizer});
680         }
681         when (1) {
682             is($first, 1, "Lecical loop: first");
683             $first = 0;
684             # Implicit break is okay
685         }
686     }
687 }
688
689
690 # Code references
691 {
692     no warnings "redefine";
693     my $called_foo = 0;
694     sub foo {$called_foo = 1}
695     my $called_bar = 0;
696     sub bar {$called_bar = 1}
697     my ($matched_foo, $matched_bar) = (0, 0);
698     given(\&foo) {
699         when(\&bar) {$matched_bar = 1}
700         when(\&foo) {$matched_foo = 1}
701     }
702     is($called_foo, 0,  "Code ref comparison: foo not called");
703     is($called_bar, 0,  "Code ref comparison: bar not called");
704     is($matched_bar, 0, "Code ref didn't match different one");
705     is($matched_foo, 1, "Code ref did match itself");
706 }
707
708 sub contains_x {
709     my $x = shift;
710     return ($x =~ /x/);
711 }
712 {
713     my ($ok1, $ok2) = (0,0);
714     given("foxy!") {
715         when(contains_x($_))
716             { $ok1 = 1; continue }
717         when(\&contains_x)
718             { $ok2 = 1; continue }
719     }
720     is($ok1, 1, "Calling sub directly (true)");
721     is($ok2, 1, "Calling sub indirectly (true)");
722
723     given("foggy") {
724         when(contains_x($_))
725             { $ok1 = 2; continue }
726         when(\&contains_x)
727             { $ok2 = 2; continue }
728     }
729     is($ok1, 1, "Calling sub directly (false)");
730     is($ok2, 1, "Calling sub indirectly (false)");
731 }
732
733 # Test overloading
734 { package OverloadTest;
735
736     use overload '""' => sub{"string value of obj"};
737
738     use overload "~~" => sub {
739         my ($self, $other, $reversed) = @_;
740         if ($reversed) {
741             $self->{left}  = $other;
742             $self->{right} = $self;
743             $self->{reversed} = 1;
744         } else {
745             $self->{left}  = $self;
746             $self->{right} = $other;
747             $self->{reversed} = 0;
748         }
749         $self->{called} = 1;
750         return $self->{retval};
751     };
752     
753     sub new {
754         my ($pkg, $retval) = @_;
755         bless {
756             called => 0,
757             retval => $retval,
758         }, $pkg;
759     }
760 }
761
762 {
763     my $test = "Overloaded obj in given (true)";
764     my $obj = OverloadTest->new(1);
765     my $matched;
766     given($obj) {
767         when ("other arg") {$matched = 1}
768         default {$matched = 0}
769     }
770     
771     is($obj->{called},  1, "$test: called");
772     ok($matched, "$test: matched");
773     is($obj->{left}, "string value of obj", "$test: left");
774     is($obj->{right}, "other arg", "$test: right");
775     ok(!$obj->{reversed}, "$test: not reversed");
776 }
777
778 {
779     my $test = "Overloaded obj in given (false)";
780     my $obj = OverloadTest->new(0);
781     my $matched;
782     given($obj) {
783         when ("other arg") {$matched = 1}
784     }
785     
786     is($obj->{called},  1, "$test: called");
787     ok(!$matched, "$test: not matched");
788     is($obj->{left}, "string value of obj", "$test: left");
789     is($obj->{right}, "other arg", "$test: right");
790     ok(!$obj->{reversed}, "$test: not reversed");
791 }
792
793 {
794     my $test = "Overloaded obj in when (true)";
795     my $obj = OverloadTest->new(1);
796     my $matched;
797     given("topic") {
798         when ($obj) {$matched = 1}
799         default {$matched = 0}
800     }
801     
802     is($obj->{called},  1, "$test: called");
803     ok($matched, "$test: matched");
804     is($obj->{left}, "topic", "$test: left");
805     is($obj->{right}, "string value of obj", "$test: right");
806     ok($obj->{reversed}, "$test: reversed");
807 }
808
809 {
810     my $test = "Overloaded obj in when (false)";
811     my $obj = OverloadTest->new(0);
812     my $matched;
813     given("topic") {
814         when ($obj) {$matched = 1}
815         default {$matched = 0}
816     }
817     
818     is($obj->{called}, 1, "$test: called");
819     ok(!$matched, "$test: not matched");
820     is($obj->{left}, "topic", "$test: left");
821     is($obj->{right}, "string value of obj", "$test: right");
822     ok($obj->{reversed}, "$test: reversed");
823 }
824
825 # Okay, that'll do for now. The intricacies of the smartmatch
826 # semantics are tested in t/op/smartmatch.t
827 __END__