Fix when( scalar ... ) bug
[perl.git] / t / op / switch.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11
12 plan tests => 128;
13
14 # The behaviour of the feature pragma should be tested by lib/switch.t
15 # using the tests in t/lib/switch/*. This file tests the behaviour of
16 # the switch ops themselves.
17
18 use feature 'switch';
19
20 eval { continue };
21 like($@, qr/^Can't "continue" outside/, "continue outside");
22
23 eval { break };
24 like($@, qr/^Can't "break" outside/, "break outside");
25
26 # Scoping rules
27
28 {
29     my $x = "foo";
30     given(my $x = "bar") {
31         is($x, "bar", "given scope starts");
32     }
33     is($x, "foo", "given scope ends");
34 }
35
36 sub be_true {1}
37
38 given(my $x = "foo") {
39     when(be_true(my $x = "bar")) {
40         is($x, "bar", "given scope starts");
41     }
42     is($x, "foo", "given scope ends");
43 }
44
45 $_ = "outside";
46 given("inside") { check_outside1() }
47 sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
48
49 {
50     my $_ = "outside";
51     given("inside") { check_outside2() }
52     sub check_outside2 {
53         is($_, "outside", "\$_ lexically scoped (lexical \$_)")
54     }
55 }
56
57 # Basic string/numeric comparisons and control flow
58
59 {    
60     my $ok;
61     given(3) {
62         when(2) { $ok = 'two'; }
63         when(3) { $ok = 'three'; }
64         when(4) { $ok = 'four'; }
65         default { $ok = 'd'; }
66     }
67     is($ok, 'three', "numeric comparison");
68 }
69
70 {    
71     my $ok;
72     use integer;
73     given(3.14159265) {
74         when(2) { $ok = 'two'; }
75         when(3) { $ok = 'three'; }
76         when(4) { $ok = 'four'; }
77         default { $ok = 'd'; }
78     }
79     is($ok, 'three', "integer comparison");
80 }
81
82 {    
83     my ($ok1, $ok2);
84     given(3) {
85         when(3.1)   { $ok1 = 'n'; }
86         when(3.0)   { $ok1 = 'y'; continue }
87         when("3.0") { $ok2 = 'y'; }
88         default     { $ok2 = 'n'; }
89     }
90     is($ok1, 'y', "more numeric (pt. 1)");
91     is($ok2, 'y', "more numeric (pt. 2)");
92 }
93
94 {
95     my $ok;
96     given("c") {
97         when("b") { $ok = 'B'; }
98         when("c") { $ok = 'C'; }
99         when("d") { $ok = 'D'; }
100         default   { $ok = 'def'; }
101     }
102     is($ok, 'C', "string comparison");
103 }
104
105 {
106     my $ok;
107     given("c") {
108         when("b") { $ok = 'B'; }
109         when("c") { $ok = 'C'; continue }
110         when("c") { $ok = 'CC'; }
111         default   { $ok = 'D'; }
112     }
113     is($ok, 'CC', "simple continue");
114 }
115
116 # Definedness
117 {
118     my $ok = 1;
119     given (0) { when(undef) {$ok = 0} }
120     is($ok, 1, "Given(0) when(undef)");
121 }
122 {
123     my $undef;
124     my $ok = 1;
125     given (0) { when($undef) {$ok = 0} }
126     is($ok, 1, 'Given(0) when($undef)');
127 }
128 {
129     my $undef;
130     my $ok = 0;
131     given (0) { when($undef++) {$ok = 1} }
132     is($ok, 1, "Given(0) when($undef++)");
133 }
134 {
135     no warnings "uninitialized";
136     my $ok = 1;
137     given (undef) { when(0) {$ok = 0} }
138     is($ok, 1, "Given(undef) when(0)");
139 }
140 {
141     no warnings "uninitialized";
142     my $undef;
143     my $ok = 1;
144     given ($undef) { when(0) {$ok = 0} }
145     is($ok, 1, 'Given($undef) when(0)');
146 }
147 ########
148 {
149     my $ok = 1;
150     given ("") { when(undef) {$ok = 0} }
151     is($ok, 1, 'Given("") when(undef)');
152 }
153 {
154     my $undef;
155     my $ok = 1;
156     given ("") { when($undef) {$ok = 0} }
157     is($ok, 1, 'Given("") when($undef)');
158 }
159 {
160     no warnings "uninitialized";
161     my $ok = 1;
162     given (undef) { when("") {$ok = 0} }
163     is($ok, 1, 'Given(undef) when("")');
164 }
165 {
166     no warnings "uninitialized";
167     my $undef;
168     my $ok = 1;
169     given ($undef) { when("") {$ok = 0} }
170     is($ok, 1, 'Given($undef) when("")');
171 }
172 ########
173 {
174     my $ok = 0;
175     given (undef) { when(undef) {$ok = 1} }
176     is($ok, 1, "Given(undef) when(undef)");
177 }
178 {
179     my $undef;
180     my $ok = 0;
181     given (undef) { when($undef) {$ok = 1} }
182     is($ok, 1, 'Given(undef) when($undef)');
183 }
184 {
185     my $undef;
186     my $ok = 0;
187     given ($undef) { when(undef) {$ok = 1} }
188     is($ok, 1, 'Given($undef) when(undef)');
189 }
190 {
191     my $undef;
192     my $ok = 0;
193     given ($undef) { when($undef) {$ok = 1} }
194     is($ok, 1, 'Given($undef) when($undef)');
195 }
196
197
198 # Regular expressions
199 {
200     my ($ok1, $ok2);
201     given("Hello, world!") {
202         when(/lo/)
203             { $ok1 = 'y'; continue}
204         when(/no/)
205             { $ok1 = 'n'; continue}
206         when(/^(Hello,|Goodbye cruel) world[!.?]/)
207             { $ok2 = 'Y'; continue}
208         when(/^(Hello cruel|Goodbye,) world[!.?]/)
209             { $ok2 = 'n'; continue}
210     }
211     is($ok1, 'y', "regex 1");
212     is($ok2, 'Y', "regex 2");
213 }
214
215 # Comparisons
216 {
217     my $test = "explicit numeric comparison (<)";
218     my $twenty_five = 25;
219     my $ok;
220     given($twenty_five) {
221         when ($_ < 10) { $ok = "ten" }
222         when ($_ < 20) { $ok = "twenty" }
223         when ($_ < 30) { $ok = "thirty" }
224         when ($_ < 40) { $ok = "forty" }
225         default        { $ok = "default" }
226     }
227     is($ok, "thirty", $test);
228 }
229
230 {
231     use integer;
232     my $test = "explicit numeric comparison (integer <)";
233     my $twenty_five = 25;
234     my $ok;
235     given($twenty_five) {
236         when ($_ < 10) { $ok = "ten" }
237         when ($_ < 20) { $ok = "twenty" }
238         when ($_ < 30) { $ok = "thirty" }
239         when ($_ < 40) { $ok = "forty" }
240         default        { $ok = "default" }
241     }
242     is($ok, "thirty", $test);
243 }
244
245 {
246     my $test = "explicit numeric comparison (<=)";
247     my $twenty_five = 25;
248     my $ok;
249     given($twenty_five) {
250         when ($_ <= 10) { $ok = "ten" }
251         when ($_ <= 20) { $ok = "twenty" }
252         when ($_ <= 30) { $ok = "thirty" }
253         when ($_ <= 40) { $ok = "forty" }
254         default         { $ok = "default" }
255     }
256     is($ok, "thirty", $test);
257 }
258
259 {
260     use integer;
261     my $test = "explicit numeric comparison (integer <=)";
262     my $twenty_five = 25;
263     my $ok;
264     given($twenty_five) {
265         when ($_ <= 10) { $ok = "ten" }
266         when ($_ <= 20) { $ok = "twenty" }
267         when ($_ <= 30) { $ok = "thirty" }
268         when ($_ <= 40) { $ok = "forty" }
269         default         { $ok = "default" }
270     }
271     is($ok, "thirty", $test);
272 }
273
274
275 {
276     my $test = "explicit numeric comparison (>)";
277     my $twenty_five = 25;
278     my $ok;
279     given($twenty_five) {
280         when ($_ > 40) { $ok = "forty" }
281         when ($_ > 30) { $ok = "thirty" }
282         when ($_ > 20) { $ok = "twenty" }
283         when ($_ > 10) { $ok = "ten" }
284         default        { $ok = "default" }
285     }
286     is($ok, "twenty", $test);
287 }
288
289 {
290     my $test = "explicit numeric comparison (>=)";
291     my $twenty_five = 25;
292     my $ok;
293     given($twenty_five) {
294         when ($_ >= 40) { $ok = "forty" }
295         when ($_ >= 30) { $ok = "thirty" }
296         when ($_ >= 20) { $ok = "twenty" }
297         when ($_ >= 10) { $ok = "ten" }
298         default         { $ok = "default" }
299     }
300     is($ok, "twenty", $test);
301 }
302
303 {
304     use integer;
305     my $test = "explicit numeric comparison (integer >)";
306     my $twenty_five = 25;
307     my $ok;
308     given($twenty_five) {
309         when ($_ > 40) { $ok = "forty" }
310         when ($_ > 30) { $ok = "thirty" }
311         when ($_ > 20) { $ok = "twenty" }
312         when ($_ > 10) { $ok = "ten" }
313         default        { $ok = "default" }
314     }
315     is($ok, "twenty", $test);
316 }
317
318 {
319     use integer;
320     my $test = "explicit numeric comparison (integer >=)";
321     my $twenty_five = 25;
322     my $ok;
323     given($twenty_five) {
324         when ($_ >= 40) { $ok = "forty" }
325         when ($_ >= 30) { $ok = "thirty" }
326         when ($_ >= 20) { $ok = "twenty" }
327         when ($_ >= 10) { $ok = "ten" }
328         default         { $ok = "default" }
329     }
330     is($ok, "twenty", $test);
331 }
332
333
334 {
335     my $test = "explicit string comparison (lt)";
336     my $twenty_five = "25";
337     my $ok;
338     given($twenty_five) {
339         when ($_ lt "10") { $ok = "ten" }
340         when ($_ lt "20") { $ok = "twenty" }
341         when ($_ lt "30") { $ok = "thirty" }
342         when ($_ lt "40") { $ok = "forty" }
343         default           { $ok = "default" }
344     }
345     is($ok, "thirty", $test);
346 }
347
348 {
349     my $test = "explicit string comparison (le)";
350     my $twenty_five = "25";
351     my $ok;
352     given($twenty_five) {
353         when ($_ le "10") { $ok = "ten" }
354         when ($_ le "20") { $ok = "twenty" }
355         when ($_ le "30") { $ok = "thirty" }
356         when ($_ le "40") { $ok = "forty" }
357         default           { $ok = "default" }
358     }
359     is($ok, "thirty", $test);
360 }
361
362 {
363     my $test = "explicit string comparison (gt)";
364     my $twenty_five = 25;
365     my $ok;
366     given($twenty_five) {
367         when ($_ ge "40") { $ok = "forty" }
368         when ($_ ge "30") { $ok = "thirty" }
369         when ($_ ge "20") { $ok = "twenty" }
370         when ($_ ge "10") { $ok = "ten" }
371         default           { $ok = "default" }
372     }
373     is($ok, "twenty", $test);
374 }
375
376 {
377     my $test = "explicit string comparison (ge)";
378     my $twenty_five = 25;
379     my $ok;
380     given($twenty_five) {
381         when ($_ ge "40") { $ok = "forty" }
382         when ($_ ge "30") { $ok = "thirty" }
383         when ($_ ge "20") { $ok = "twenty" }
384         when ($_ ge "10") { $ok = "ten" }
385         default           { $ok = "default" }
386     }
387     is($ok, "twenty", $test);
388 }
389
390 # Make sure it still works with a lexical $_:
391 {
392     my $_;
393     my $test = "explicit comparison with lexical \$_";
394     my $twenty_five = 25;
395     my $ok;
396     given($twenty_five) {
397         when ($_ ge "40") { $ok = "forty" }
398         when ($_ ge "30") { $ok = "thirty" }
399         when ($_ ge "20") { $ok = "twenty" }
400         when ($_ ge "10") { $ok = "ten" }
401         default           { $ok = "default" }
402     }
403     is($ok, "twenty", $test);
404 }
405
406 # Optimized-away comparisons
407 {
408     my $ok;
409     given(23) {
410         when (2 + 2 == 4) { $ok = 'y'; continue }
411         when (2 + 2 == 5) { $ok = 'n' }
412     }
413     is($ok, 'y', "Optimized-away comparison");
414 }
415
416 {
417     my $ok;
418     given(23) {
419         when (scalar 24) { $ok = 'n'; continue }
420         default { $ok = 'y' }
421     }
422     is($ok,'y','scalar()');
423 }
424
425 # File tests
426 #  (How to be both thorough and portable? Pinch a few ideas
427 #  from t/op/filetest.t. We err on the side of portability for
428 #  the time being.)
429
430 {
431     my ($ok_d, $ok_f, $ok_r);
432     given("op") {
433         when(-d)  {$ok_d = 1; continue}
434         when(!-f) {$ok_f = 1; continue}
435         when(-r)  {$ok_r = 1; continue}
436     }
437     ok($ok_d, "Filetest -d");
438     ok($ok_f, "Filetest -f");
439     ok($ok_r, "Filetest -r");
440 }
441
442 # Sub and method calls
443 sub notfoo {"bar"}
444 {
445     my $ok = 0;
446     given("foo") {
447         when(notfoo()) {$ok = 1}
448     }
449     ok($ok, "Sub call acts as boolean")
450 }
451
452 {
453     my $ok = 0;
454     given("foo") {
455         when(main->notfoo()) {$ok = 1}
456     }
457     ok($ok, "Class-method call acts as boolean")
458 }
459
460 {
461     my $ok = 0;
462     my $obj = bless [];
463     given("foo") {
464         when($obj->notfoo()) {$ok = 1}
465     }
466     ok($ok, "Object-method call acts as boolean")
467 }
468
469 # Other things that should not be smart matched
470 {
471     my $ok = 0;
472     given(12) {
473         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
474             $ok = 1;
475         }
476     }
477     ok($ok, "bool not smartmatches");
478 }
479
480 {
481     my $ok = 0;
482     given(0) {
483         when(eof(DATA)) {
484             $ok = 1;
485         }
486     }
487     ok($ok, "eof() not smartmatched");
488 }
489
490 {
491     my $ok = 0;
492     my %foo = ("bar", 0);
493     given(0) {
494         when(exists $foo{bar}) {
495             $ok = 1;
496         }
497     }
498     ok($ok, "exists() not smartmatched");
499 }
500
501 {
502     my $ok = 0;
503     given(0) {
504         when(defined $ok) {
505             $ok = 1;
506         }
507     }
508     ok($ok, "defined() not smartmatched");
509 }
510
511 {
512     my $ok = 1;
513     given("foo") {
514         when((1 == 1) && "bar") {
515             $ok = 0;
516         }
517         when((1 == 1) && $_ eq "foo") {
518             $ok = 2;
519         }
520     }
521     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
522 }
523
524 {
525     my $n = 0;
526     for my $l qw(a b c d) {
527         given ($l) {
528             when ($_ eq "b" .. $_ eq "c") { $n = 1 }
529             default { $n = 0 }
530         }
531         ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
532     }
533 }
534
535 {
536     my $n = 0;
537     for my $l qw(a b c d) {
538         given ($l) {
539             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
540             default { $n = 0 }
541         }
542         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
543     }
544 }
545
546 {
547     my $ok = 0;
548     given("foo") {
549         when((1 == $ok) || "foo") {
550             $ok = 1;
551         }
552     }
553     ok($ok, '((1 == $ok) || "foo") smartmatched');
554 }
555
556 {
557     my $ok = 0;
558     given("foo") {
559         when((1 == $ok || undef) // "foo") {
560             $ok = 1;
561         }
562     }
563     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
564 }
565
566 # Make sure we aren't invoking the get-magic more than once
567
568 { # A helper class to count the number of accesses.
569     package FetchCounter;
570     sub TIESCALAR {
571         my ($class) = @_;
572         bless {value => undef, count => 0}, $class;
573     }
574     sub STORE {
575         my ($self, $val) = @_;
576         $self->{count} = 0;
577         $self->{value} = $val;
578     }
579     sub FETCH {
580         my ($self) = @_;
581         # Avoid pre/post increment here
582         $self->{count} = 1 + $self->{count};
583         $self->{value};
584     }
585     sub count {
586         my ($self) = @_;
587         $self->{count};
588     }
589 }
590
591 my $f = tie my $v, "FetchCounter";
592
593 {   my $test_name = "Only one FETCH (in given)";
594     my $ok;
595     given($v = 23) {
596         when(undef) {}
597         when(sub{0}->()) {}
598         when(21) {}
599         when("22") {}
600         when(23) {$ok = 1}
601         when(/24/) {$ok = 0}
602     }
603     is($ok, 1, "precheck: $test_name");
604     is($f->count(), 1, $test_name);
605 }
606
607 {   my $test_name = "Only one FETCH (numeric when)";
608     my $ok;
609     $v = 23;
610     is($f->count(), 0, "Sanity check: $test_name");
611     given(23) {
612         when(undef) {}
613         when(sub{0}->()) {}
614         when(21) {}
615         when("22") {}
616         when($v) {$ok = 1}
617         when(/24/) {$ok = 0}
618     }
619     is($ok, 1, "precheck: $test_name");
620     is($f->count(), 1, $test_name);
621 }
622
623 {   my $test_name = "Only one FETCH (string when)";
624     my $ok;
625     $v = "23";
626     is($f->count(), 0, "Sanity check: $test_name");
627     given("23") {
628         when(undef) {}
629         when(sub{0}->()) {}
630         when("21") {}
631         when("22") {}
632         when($v) {$ok = 1}
633         when(/24/) {$ok = 0}
634     }
635     is($ok, 1, "precheck: $test_name");
636     is($f->count(), 1, $test_name);
637 }
638
639 {   my $test_name = "Only one FETCH (undef)";
640     my $ok;
641     $v = undef;
642     is($f->count(), 0, "Sanity check: $test_name");
643     no warnings "uninitialized";
644     given(my $undef) {
645         when(sub{0}->()) {}
646         when("21")  {}
647         when("22")  {}
648         when($v)    {$ok = 1}
649         when(undef) {$ok = 0}
650     }
651     is($ok, 1, "precheck: $test_name");
652     is($f->count(), 1, $test_name);
653 }
654
655 # Loop topicalizer
656 {
657     my $first = 1;
658     for (1, "two") {
659         when ("two") {
660             is($first, 0, "Loop: second");
661             eval {break};
662             like($@, qr/^Can't "break" in a loop topicalizer/,
663                 q{Can't "break" in a loop topicalizer});
664         }
665         when (1) {
666             is($first, 1, "Loop: first");
667             $first = 0;
668             # Implicit break is okay
669         }
670     }
671 }
672
673 {
674     my $first = 1;
675     for $_ (1, "two") {
676         when ("two") {
677             is($first, 0, "Explicit \$_: second");
678             eval {break};
679             like($@, qr/^Can't "break" in a loop topicalizer/,
680                 q{Can't "break" in a loop topicalizer});
681         }
682         when (1) {
683             is($first, 1, "Explicit \$_: first");
684             $first = 0;
685             # Implicit break is okay
686         }
687     }
688 }
689
690 {
691     my $first = 1;
692     my $_;
693     for (1, "two") {
694         when ("two") {
695             is($first, 0, "Implicitly lexical loop: second");
696             eval {break};
697             like($@, qr/^Can't "break" in a loop topicalizer/,
698                 q{Can't "break" in a loop topicalizer});
699         }
700         when (1) {
701             is($first, 1, "Implicitly lexical loop: first");
702             $first = 0;
703             # Implicit break is okay
704         }
705     }
706 }
707
708 {
709     my $first = 1;
710     my $_;
711     for $_ (1, "two") {
712         when ("two") {
713             is($first, 0, "Implicitly lexical, explicit \$_: second");
714             eval {break};
715             like($@, qr/^Can't "break" in a loop topicalizer/,
716                 q{Can't "break" in a loop topicalizer});
717         }
718         when (1) {
719             is($first, 1, "Implicitly lexical, explicit \$_: first");
720             $first = 0;
721             # Implicit break is okay
722         }
723     }
724 }
725
726 {
727     my $first = 1;
728     for my $_ (1, "two") {
729         when ("two") {
730             is($first, 0, "Lexical loop: second");
731             eval {break};
732             like($@, qr/^Can't "break" in a loop topicalizer/,
733                 q{Can't "break" in a loop topicalizer});
734         }
735         when (1) {
736             is($first, 1, "Lexical loop: first");
737             $first = 0;
738             # Implicit break is okay
739         }
740     }
741 }
742
743
744 # Code references
745 {
746     my $called_foo = 0;
747     sub foo {$called_foo = 1; "@_" eq "foo"}
748     my $called_bar = 0;
749     sub bar {$called_bar = 1; "@_" eq "bar"}
750     my ($matched_foo, $matched_bar) = (0, 0);
751     given("foo") {
752         when(\&bar) {$matched_bar = 1}
753         when(\&foo) {$matched_foo = 1}
754     }
755     is($called_foo, 1,  "foo() was called");
756     is($called_bar, 1,  "bar() was called");
757     is($matched_bar, 0, "bar didn't match");
758     is($matched_foo, 1, "foo did match");
759 }
760
761 sub contains_x {
762     my $x = shift;
763     return ($x =~ /x/);
764 }
765 {
766     my ($ok1, $ok2) = (0,0);
767     given("foxy!") {
768         when(contains_x($_))
769             { $ok1 = 1; continue }
770         when(\&contains_x)
771             { $ok2 = 1; continue }
772     }
773     is($ok1, 1, "Calling sub directly (true)");
774     is($ok2, 1, "Calling sub indirectly (true)");
775
776     given("foggy") {
777         when(contains_x($_))
778             { $ok1 = 2; continue }
779         when(\&contains_x)
780             { $ok2 = 2; continue }
781     }
782     is($ok1, 1, "Calling sub directly (false)");
783     is($ok2, 1, "Calling sub indirectly (false)");
784 }
785
786 SKIP: {
787     skip "Scalar/Util.pm not yet available", 20
788         unless -r "$INC[0]/Scalar/Util.pm";
789     # Test overloading
790     { package OverloadTest;
791
792       use overload '""' => sub{"string value of obj"};
793       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
794
795       use overload "~~" => sub {
796           my ($self, $other, $reversed) = @_;
797           if ($reversed) {
798               $self->{left}  = $other;
799               $self->{right} = $self;
800               $self->{reversed} = 1;
801           } else {
802               $self->{left}  = $self;
803               $self->{right} = $other;
804               $self->{reversed} = 0;
805           }
806           $self->{called} = 1;
807           return $self->{retval};
808       };
809     
810       sub new {
811           my ($pkg, $retval) = @_;
812           bless {
813                  called => 0,
814                  retval => $retval,
815                 }, $pkg;
816       }
817   }
818
819     {
820         my $test = "Overloaded obj in given (true)";
821         my $obj = OverloadTest->new(1);
822         my $matched;
823         given($obj) {
824             when ("other arg") {$matched = 1}
825             default {$matched = 0}
826         }
827     
828         is($obj->{called}, 1, "$test: called");
829         ok($matched, "$test: matched");
830     }
831
832     {
833         my $test = "Overloaded obj in given (false)";
834         my $obj = OverloadTest->new(0);
835         my $matched;
836         given($obj) {
837             when ("other arg") {$matched = 1}
838         }
839     
840         is($obj->{called}, 1, "$test: called");
841         ok(!$matched, "$test: not matched");
842     }
843
844     {
845         my $test = "Overloaded obj in when (true)";
846         my $obj = OverloadTest->new(1);
847         my $matched;
848         given("topic") {
849             when ($obj) {$matched = 1}
850             default {$matched = 0}
851         }
852     
853         is($obj->{called},  1, "$test: called");
854         ok($matched, "$test: matched");
855         is($obj->{left}, "topic", "$test: left");
856         is($obj->{right}, "string value of obj", "$test: right");
857         ok($obj->{reversed}, "$test: reversed");
858     }
859
860     {
861         my $test = "Overloaded obj in when (false)";
862         my $obj = OverloadTest->new(0);
863         my $matched;
864         given("topic") {
865             when ($obj) {$matched = 1}
866             default {$matched = 0}
867         }
868     
869         is($obj->{called}, 1, "$test: called");
870         ok(!$matched, "$test: not matched");
871         is($obj->{left}, "topic", "$test: left");
872         is($obj->{right}, "string value of obj", "$test: right");
873         ok($obj->{reversed}, "$test: reversed");
874     }
875 }
876
877 # Postfix when
878 {
879     my $ok;
880     given (undef) {
881         $ok = 1 when undef;
882     }
883     is($ok, 1, "postfix undef");
884 }
885 {
886     my $ok;
887     given (2) {
888         $ok += 1 when 7;
889         $ok += 2 when 9.1685;
890         $ok += 4 when $_ > 4;
891         $ok += 8 when $_ < 2.5;
892     }
893     is($ok, 8, "postfix numeric");
894 }
895 {
896     my $ok;
897     given ("apple") {
898         $ok = 1, continue when $_ eq "apple";
899         $ok += 2;
900         $ok = 0 when "banana";
901     }
902     is($ok, 3, "postfix string");
903 }
904 {
905     my $ok;
906     given ("pear") {
907         do { $ok = 1; continue } when /pea/;
908         $ok += 2;
909         $ok = 0 when /pie/;
910         default { $ok += 4 }
911         $ok = 0;
912     }
913     is($ok, 7, "postfix regex");
914 }
915 # be_true is defined at the beginning of the file
916 {
917     my $x = "what";
918     given(my $x = "foo") {
919         do {
920             is($x, "foo", "scope inside ... when my \$x = ...");
921             continue;
922         } when be_true(my $x = "bar");
923         is($x, "bar", "scope after ... when my \$x = ...");
924     }
925 }
926 {
927     my $x = 0;
928     given(my $x = 1) {
929         my $x = 2, continue when be_true();
930         is($x, undef, "scope after my \$x = ... when ...");
931     }
932 }
933
934 # Tests for last and next in when clauses
935 my $letter;
936
937 $letter = '';
938 for ("a".."e") {
939     given ($_) {
940         $letter = $_;
941         when ("b") { last }
942     }
943     $letter = "z";
944 }
945 is($letter, "b", "last in when");
946
947 $letter = '';
948 LETTER1: for ("a".."e") {
949     given ($_) {
950         $letter = $_;
951         when ("b") { last LETTER1 }
952     }
953     $letter = "z";
954 }
955 is($letter, "b", "last LABEL in when");
956
957 $letter = '';
958 for ("a".."e") {
959     given ($_) {
960         when (/b|d/) { next }
961         $letter .= $_;
962     }
963     $letter .= ',';
964 }
965 is($letter, "a,c,e,", "next in when");
966
967 $letter = '';
968 LETTER2: for ("a".."e") {
969     given ($_) {
970         when (/b|d/) { next LETTER2 }
971         $letter .= $_;
972     }
973     $letter .= ',';
974 }
975 is($letter, "a,c,e,", "next LABEL in when");
976
977 # Test goto with given/when
978 {
979     my $flag = 0;
980     goto GIVEN1;
981     $flag = 1;
982     GIVEN1: given ($flag) {
983         when (0) { break; }
984         $flag = 2;
985     }
986     is($flag, 0, "goto GIVEN1");
987 }
988 {
989     my $flag = 0;
990     given ($flag) {
991         when (0) { $flag = 1; }
992         goto GIVEN2;
993         $flag = 2;
994     }
995 GIVEN2:
996     is($flag, 1, "goto inside given");
997 }
998 {
999     my $flag = 0;
1000     given ($flag) {
1001         when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
1002         $flag = 3;
1003     }
1004 GIVEN3:
1005     is($flag, 1, "goto inside given and when");
1006 }
1007 {
1008     my $flag = 0;
1009     for ($flag) {
1010         when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
1011         $flag = 3;
1012     }
1013 GIVEN4:
1014     is($flag, 1, "goto inside for and when");
1015 }
1016 {
1017     my $flag = 0;
1018 GIVEN5:
1019     given ($flag) {
1020         when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
1021         when (1) { break; }
1022         $flag = 3;
1023     }
1024     is($flag, 1, "goto inside given and when to the given stmt");
1025 }
1026
1027 # Okay, that'll do for now. The intricacies of the smartmatch
1028 # semantics are tested in t/op/smartmatch.t
1029 __END__