Epigraph for 5.29.8
[perl.git] / t / op / switch.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 use strict;
10 use warnings;
11 no warnings 'experimental::smartmatch';
12
13 plan tests => 197;
14
15 # The behaviour of the feature pragma should be tested by lib/feature.t
16 # using the tests in t/lib/feature/*. This file tests the behaviour of
17 # the switch ops themselves.
18
19
20 # Before loading feature, test the switch ops with CORE::
21 CORE::given(3) {
22     CORE::when(3) { pass "CORE::given and CORE::when"; continue }
23     CORE::default { pass "continue (without feature) and CORE::default" }
24 }
25
26
27 use feature 'switch';
28
29 eval { continue };
30 like($@, qr/^Can't "continue" outside/, "continue outside");
31
32 eval { break };
33 like($@, qr/^Can't "break" outside/, "break outside");
34
35 # Scoping rules
36
37 {
38     my $x = "foo";
39     given(my $x = "bar") {
40         is($x, "bar", "given scope starts");
41     }
42     is($x, "foo", "given scope ends");
43 }
44
45 sub be_true {1}
46
47 given(my $x = "foo") {
48     when(be_true(my $x = "bar")) {
49         is($x, "bar", "given scope starts");
50     }
51     is($x, "foo", "given scope ends");
52 }
53
54 $_ = "outside";
55 given("inside") { check_outside1() }
56 sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
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     no warnings "uninitialized";
137     my $ok = 1;
138     given (undef) { when(0) {$ok = 0} }
139     is($ok, 1, "Given(undef) when(0)");
140 }
141 {
142     no warnings "uninitialized";
143     my $undef;
144     my $ok = 1;
145     given ($undef) { when(0) {$ok = 0} }
146     is($ok, 1, 'Given($undef) when(0)');
147 }
148 ########
149 {
150     my $ok = 1;
151     given ("") { when(undef) {$ok = 0} }
152     is($ok, 1, 'Given("") when(undef)');
153 }
154 {
155     my $undef;
156     my $ok = 1;
157     given ("") { when($undef) {$ok = 0} }
158     is($ok, 1, 'Given("") when($undef)');
159 }
160 {
161     no warnings "uninitialized";
162     my $ok = 1;
163     given (undef) { when("") {$ok = 0} }
164     is($ok, 1, 'Given(undef) when("")');
165 }
166 {
167     no warnings "uninitialized";
168     my $undef;
169     my $ok = 1;
170     given ($undef) { when("") {$ok = 0} }
171     is($ok, 1, 'Given($undef) when("")');
172 }
173 ########
174 {
175     my $ok = 0;
176     given (undef) { when(undef) {$ok = 1} }
177     is($ok, 1, "Given(undef) when(undef)");
178 }
179 {
180     my $undef;
181     my $ok = 0;
182     given (undef) { when($undef) {$ok = 1} }
183     is($ok, 1, 'Given(undef) when($undef)');
184 }
185 {
186     my $undef;
187     my $ok = 0;
188     given ($undef) { when(undef) {$ok = 1} }
189     is($ok, 1, 'Given($undef) when(undef)');
190 }
191 {
192     my $undef;
193     my $ok = 0;
194     given ($undef) { when($undef) {$ok = 1} }
195     is($ok, 1, 'Given($undef) when($undef)');
196 }
197
198
199 # Regular expressions
200 {
201     my ($ok1, $ok2);
202     given("Hello, world!") {
203         when(/lo/)
204             { $ok1 = 'y'; continue}
205         when(/no/)
206             { $ok1 = 'n'; continue}
207         when(/^(Hello,|Goodbye cruel) world[!.?]/)
208             { $ok2 = 'Y'; continue}
209         when(/^(Hello cruel|Goodbye,) world[!.?]/)
210             { $ok2 = 'n'; continue}
211     }
212     is($ok1, 'y', "regex 1");
213     is($ok2, 'Y', "regex 2");
214 }
215
216 # Comparisons
217 {
218     my $test = "explicit numeric comparison (<)";
219     my $twenty_five = 25;
220     my $ok;
221     given($twenty_five) {
222         when ($_ < 10) { $ok = "ten" }
223         when ($_ < 20) { $ok = "twenty" }
224         when ($_ < 30) { $ok = "thirty" }
225         when ($_ < 40) { $ok = "forty" }
226         default        { $ok = "default" }
227     }
228     is($ok, "thirty", $test);
229 }
230
231 {
232     use integer;
233     my $test = "explicit numeric comparison (integer <)";
234     my $twenty_five = 25;
235     my $ok;
236     given($twenty_five) {
237         when ($_ < 10) { $ok = "ten" }
238         when ($_ < 20) { $ok = "twenty" }
239         when ($_ < 30) { $ok = "thirty" }
240         when ($_ < 40) { $ok = "forty" }
241         default        { $ok = "default" }
242     }
243     is($ok, "thirty", $test);
244 }
245
246 {
247     my $test = "explicit numeric comparison (<=)";
248     my $twenty_five = 25;
249     my $ok;
250     given($twenty_five) {
251         when ($_ <= 10) { $ok = "ten" }
252         when ($_ <= 20) { $ok = "twenty" }
253         when ($_ <= 30) { $ok = "thirty" }
254         when ($_ <= 40) { $ok = "forty" }
255         default         { $ok = "default" }
256     }
257     is($ok, "thirty", $test);
258 }
259
260 {
261     use integer;
262     my $test = "explicit numeric comparison (integer <=)";
263     my $twenty_five = 25;
264     my $ok;
265     given($twenty_five) {
266         when ($_ <= 10) { $ok = "ten" }
267         when ($_ <= 20) { $ok = "twenty" }
268         when ($_ <= 30) { $ok = "thirty" }
269         when ($_ <= 40) { $ok = "forty" }
270         default         { $ok = "default" }
271     }
272     is($ok, "thirty", $test);
273 }
274
275
276 {
277     my $test = "explicit numeric comparison (>)";
278     my $twenty_five = 25;
279     my $ok;
280     given($twenty_five) {
281         when ($_ > 40) { $ok = "forty" }
282         when ($_ > 30) { $ok = "thirty" }
283         when ($_ > 20) { $ok = "twenty" }
284         when ($_ > 10) { $ok = "ten" }
285         default        { $ok = "default" }
286     }
287     is($ok, "twenty", $test);
288 }
289
290 {
291     my $test = "explicit numeric comparison (>=)";
292     my $twenty_five = 25;
293     my $ok;
294     given($twenty_five) {
295         when ($_ >= 40) { $ok = "forty" }
296         when ($_ >= 30) { $ok = "thirty" }
297         when ($_ >= 20) { $ok = "twenty" }
298         when ($_ >= 10) { $ok = "ten" }
299         default         { $ok = "default" }
300     }
301     is($ok, "twenty", $test);
302 }
303
304 {
305     use integer;
306     my $test = "explicit numeric comparison (integer >)";
307     my $twenty_five = 25;
308     my $ok;
309     given($twenty_five) {
310         when ($_ > 40) { $ok = "forty" }
311         when ($_ > 30) { $ok = "thirty" }
312         when ($_ > 20) { $ok = "twenty" }
313         when ($_ > 10) { $ok = "ten" }
314         default        { $ok = "default" }
315     }
316     is($ok, "twenty", $test);
317 }
318
319 {
320     use integer;
321     my $test = "explicit numeric comparison (integer >=)";
322     my $twenty_five = 25;
323     my $ok;
324     given($twenty_five) {
325         when ($_ >= 40) { $ok = "forty" }
326         when ($_ >= 30) { $ok = "thirty" }
327         when ($_ >= 20) { $ok = "twenty" }
328         when ($_ >= 10) { $ok = "ten" }
329         default         { $ok = "default" }
330     }
331     is($ok, "twenty", $test);
332 }
333
334
335 {
336     my $test = "explicit string comparison (lt)";
337     my $twenty_five = "25";
338     my $ok;
339     given($twenty_five) {
340         when ($_ lt "10") { $ok = "ten" }
341         when ($_ lt "20") { $ok = "twenty" }
342         when ($_ lt "30") { $ok = "thirty" }
343         when ($_ lt "40") { $ok = "forty" }
344         default           { $ok = "default" }
345     }
346     is($ok, "thirty", $test);
347 }
348
349 {
350     my $test = "explicit string comparison (le)";
351     my $twenty_five = "25";
352     my $ok;
353     given($twenty_five) {
354         when ($_ le "10") { $ok = "ten" }
355         when ($_ le "20") { $ok = "twenty" }
356         when ($_ le "30") { $ok = "thirty" }
357         when ($_ le "40") { $ok = "forty" }
358         default           { $ok = "default" }
359     }
360     is($ok, "thirty", $test);
361 }
362
363 {
364     my $test = "explicit string comparison (gt)";
365     my $twenty_five = 25;
366     my $ok;
367     given($twenty_five) {
368         when ($_ ge "40") { $ok = "forty" }
369         when ($_ ge "30") { $ok = "thirty" }
370         when ($_ ge "20") { $ok = "twenty" }
371         when ($_ ge "10") { $ok = "ten" }
372         default           { $ok = "default" }
373     }
374     is($ok, "twenty", $test);
375 }
376
377 {
378     my $test = "explicit string comparison (ge)";
379     my $twenty_five = 25;
380     my $ok;
381     given($twenty_five) {
382         when ($_ ge "40") { $ok = "forty" }
383         when ($_ ge "30") { $ok = "thirty" }
384         when ($_ ge "20") { $ok = "twenty" }
385         when ($_ ge "10") { $ok = "ten" }
386         default           { $ok = "default" }
387     }
388     is($ok, "twenty", $test);
389 }
390
391 # Optimized-away comparisons
392 {
393     my $ok;
394     given(23) {
395         when (2 + 2 == 4) { $ok = 'y'; continue }
396         when (2 + 2 == 5) { $ok = 'n' }
397     }
398     is($ok, 'y', "Optimized-away comparison");
399 }
400
401 {
402     my $ok;
403     given(23) {
404         when (scalar 24) { $ok = 'n'; continue }
405         default { $ok = 'y' }
406     }
407     is($ok,'y','scalar()');
408 }
409
410 # File tests
411 #  (How to be both thorough and portable? Pinch a few ideas
412 #  from t/op/filetest.t. We err on the side of portability for
413 #  the time being.)
414
415 {
416     my ($ok_d, $ok_f, $ok_r);
417     given("op") {
418         when(-d)  {$ok_d = 1; continue}
419         when(!-f) {$ok_f = 1; continue}
420         when(-r)  {$ok_r = 1; continue}
421     }
422     ok($ok_d, "Filetest -d");
423     ok($ok_f, "Filetest -f");
424     ok($ok_r, "Filetest -r");
425 }
426
427 # Sub and method calls
428 sub notfoo {"bar"}
429 {
430     my $ok = 0;
431     given("foo") {
432         when(notfoo()) {$ok = 1}
433     }
434     ok($ok, "Sub call acts as boolean")
435 }
436
437 {
438     my $ok = 0;
439     given("foo") {
440         when(main->notfoo()) {$ok = 1}
441     }
442     ok($ok, "Class-method call acts as boolean")
443 }
444
445 {
446     my $ok = 0;
447     my $obj = bless [];
448     given("foo") {
449         when($obj->notfoo()) {$ok = 1}
450     }
451     ok($ok, "Object-method call acts as boolean")
452 }
453
454 # Other things that should not be smart matched
455 {
456     my $ok = 0;
457     given(12) {
458         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
459             $ok = 1;
460         }
461     }
462     ok($ok, "bool not smartmatches");
463 }
464
465 {
466     my $ok = 0;
467     given(0) {
468         when(eof(DATA)) {
469             $ok = 1;
470         }
471     }
472     ok($ok, "eof() not smartmatched");
473 }
474
475 {
476     my $ok = 0;
477     my %foo = ("bar", 0);
478     given(0) {
479         when(exists $foo{bar}) {
480             $ok = 1;
481         }
482     }
483     ok($ok, "exists() not smartmatched");
484 }
485
486 {
487     my $ok = 0;
488     given(0) {
489         when(defined $ok) {
490             $ok = 1;
491         }
492     }
493     ok($ok, "defined() not smartmatched");
494 }
495
496 {
497     my $ok = 1;
498     given("foo") {
499         when((1 == 1) && "bar") {
500             $ok = 0;
501         }
502         when((1 == 1) && $_ eq "foo") {
503             $ok = 2;
504         }
505     }
506     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
507 }
508
509 {
510     my $n = 0;
511     for my $l (qw(a b c d)) {
512         given ($l) {
513             when ($_ eq "b" .. $_ eq "c") { $n = 1 }
514             default { $n = 0 }
515         }
516         ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
517     }
518 }
519
520 {
521     my $n = 0;
522     for my $l (qw(a b c d)) {
523         given ($l) {
524             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
525             default { $n = 0 }
526         }
527         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
528     }
529 }
530
531 {
532     my $ok = 0;
533     given("foo") {
534         when((1 == $ok) || "foo") {
535             $ok = 1;
536         }
537     }
538     ok($ok, '((1 == $ok) || "foo") smartmatched');
539 }
540
541 {
542     my $ok = 0;
543     given("foo") {
544         when((1 == $ok || undef) // "foo") {
545             $ok = 1;
546         }
547     }
548     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
549 }
550
551 # Make sure we aren't invoking the get-magic more than once
552
553 { # A helper class to count the number of accesses.
554     package FetchCounter;
555     sub TIESCALAR {
556         my ($class) = @_;
557         bless {value => undef, count => 0}, $class;
558     }
559     sub STORE {
560         my ($self, $val) = @_;
561         $self->{count} = 0;
562         $self->{value} = $val;
563     }
564     sub FETCH {
565         my ($self) = @_;
566         # Avoid pre/post increment here
567         $self->{count} = 1 + $self->{count};
568         $self->{value};
569     }
570     sub count {
571         my ($self) = @_;
572         $self->{count};
573     }
574 }
575
576 my $f = tie my $v, "FetchCounter";
577
578 {   my $test_name = "Multiple FETCHes in given, due to aliasing";
579     my $ok;
580     given($v = 23) {
581         when(undef) {}
582         when(sub{0}->()) {}
583         when(21) {}
584         when("22") {}
585         when(23) {$ok = 1}
586         when(/24/) {$ok = 0}
587     }
588     is($ok, 1, "precheck: $test_name");
589     is($f->count(), 4, $test_name);
590 }
591
592 {   my $test_name = "Only one FETCH (numeric when)";
593     my $ok;
594     $v = 23;
595     is($f->count(), 0, "Sanity check: $test_name");
596     given(23) {
597         when(undef) {}
598         when(sub{0}->()) {}
599         when(21) {}
600         when("22") {}
601         when($v) {$ok = 1}
602         when(/24/) {$ok = 0}
603     }
604     is($ok, 1, "precheck: $test_name");
605     is($f->count(), 1, $test_name);
606 }
607
608 {   my $test_name = "Only one FETCH (string when)";
609     my $ok;
610     $v = "23";
611     is($f->count(), 0, "Sanity check: $test_name");
612     given("23") {
613         when(undef) {}
614         when(sub{0}->()) {}
615         when("21") {}
616         when("22") {}
617         when($v) {$ok = 1}
618         when(/24/) {$ok = 0}
619     }
620     is($ok, 1, "precheck: $test_name");
621     is($f->count(), 1, $test_name);
622 }
623
624 {   my $test_name = "Only one FETCH (undef)";
625     my $ok;
626     $v = undef;
627     is($f->count(), 0, "Sanity check: $test_name");
628     no warnings "uninitialized";
629     given(my $undef) {
630         when(sub{0}->()) {}
631         when("21")  {}
632         when("22")  {}
633         when($v)    {$ok = 1}
634         when(undef) {$ok = 0}
635     }
636     is($ok, 1, "precheck: $test_name");
637     is($f->count(), 1, $test_name);
638 }
639
640 # Loop topicalizer
641 {
642     my $first = 1;
643     for (1, "two") {
644         when ("two") {
645             is($first, 0, "Loop: second");
646             eval {break};
647             like($@, qr/^Can't "break" in a loop topicalizer/,
648                 q{Can't "break" in a loop topicalizer});
649         }
650         when (1) {
651             is($first, 1, "Loop: first");
652             $first = 0;
653             # Implicit break is okay
654         }
655     }
656 }
657
658 {
659     my $first = 1;
660     for $_ (1, "two") {
661         when ("two") {
662             is($first, 0, "Explicit \$_: second");
663             eval {break};
664             like($@, qr/^Can't "break" in a loop topicalizer/,
665                 q{Can't "break" in a loop topicalizer});
666         }
667         when (1) {
668             is($first, 1, "Explicit \$_: first");
669             $first = 0;
670             # Implicit break is okay
671         }
672     }
673 }
674
675
676 # Code references
677 {
678     my $called_foo = 0;
679     sub foo {$called_foo = 1; "@_" eq "foo"}
680     my $called_bar = 0;
681     sub bar {$called_bar = 1; "@_" eq "bar"}
682     my ($matched_foo, $matched_bar) = (0, 0);
683     given("foo") {
684         when(\&bar) {$matched_bar = 1}
685         when(\&foo) {$matched_foo = 1}
686     }
687     is($called_foo, 1,  "foo() was called");
688     is($called_bar, 1,  "bar() was called");
689     is($matched_bar, 0, "bar didn't match");
690     is($matched_foo, 1, "foo did match");
691 }
692
693 sub contains_x {
694     my $x = shift;
695     return ($x =~ /x/);
696 }
697 {
698     my ($ok1, $ok2) = (0,0);
699     given("foxy!") {
700         when(contains_x($_))
701             { $ok1 = 1; continue }
702         when(\&contains_x)
703             { $ok2 = 1; continue }
704     }
705     is($ok1, 1, "Calling sub directly (true)");
706     is($ok2, 1, "Calling sub indirectly (true)");
707
708     given("foggy") {
709         when(contains_x($_))
710             { $ok1 = 2; continue }
711         when(\&contains_x)
712             { $ok2 = 2; continue }
713     }
714     is($ok1, 1, "Calling sub directly (false)");
715     is($ok2, 1, "Calling sub indirectly (false)");
716 }
717
718 SKIP: {
719     skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
720     # Test overloading
721     { package OverloadTest;
722
723       use overload '""' => sub{"string value of obj"};
724       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
725
726       use overload "~~" => sub {
727           my ($self, $other, $reversed) = @_;
728           if ($reversed) {
729               $self->{left}  = $other;
730               $self->{right} = $self;
731               $self->{reversed} = 1;
732           } else {
733               $self->{left}  = $self;
734               $self->{right} = $other;
735               $self->{reversed} = 0;
736           }
737           $self->{called} = 1;
738           return $self->{retval};
739       };
740     
741       sub new {
742           my ($pkg, $retval) = @_;
743           bless {
744                  called => 0,
745                  retval => $retval,
746                 }, $pkg;
747       }
748   }
749
750     {
751         my $test = "Overloaded obj in given (true)";
752         my $obj = OverloadTest->new(1);
753         my $matched;
754         given($obj) {
755             when ("other arg") {$matched = 1}
756             default {$matched = 0}
757         }
758     
759         is($obj->{called}, 1, "$test: called");
760         ok($matched, "$test: matched");
761     }
762
763     {
764         my $test = "Overloaded obj in given (false)";
765         my $obj = OverloadTest->new(0);
766         my $matched;
767         given($obj) {
768             when ("other arg") {$matched = 1}
769         }
770     
771         is($obj->{called}, 1, "$test: called");
772         ok(!$matched, "$test: not matched");
773     }
774
775     {
776         my $test = "Overloaded obj in when (true)";
777         my $obj = OverloadTest->new(1);
778         my $matched;
779         given("topic") {
780             when ($obj) {$matched = 1}
781             default {$matched = 0}
782         }
783     
784         is($obj->{called},  1, "$test: called");
785         ok($matched, "$test: matched");
786         is($obj->{left}, "topic", "$test: left");
787         is($obj->{right}, "string value of obj", "$test: right");
788         ok($obj->{reversed}, "$test: reversed");
789     }
790
791     {
792         my $test = "Overloaded obj in when (false)";
793         my $obj = OverloadTest->new(0);
794         my $matched;
795         given("topic") {
796             when ($obj) {$matched = 1}
797             default {$matched = 0}
798         }
799     
800         is($obj->{called}, 1, "$test: called");
801         ok(!$matched, "$test: not matched");
802         is($obj->{left}, "topic", "$test: left");
803         is($obj->{right}, "string value of obj", "$test: right");
804         ok($obj->{reversed}, "$test: reversed");
805     }
806 }
807
808 # Postfix when
809 {
810     my $ok;
811     given (undef) {
812         $ok = 1 when undef;
813     }
814     is($ok, 1, "postfix undef");
815 }
816 {
817     my $ok;
818     given (2) {
819         $ok += 1 when 7;
820         $ok += 2 when 9.1685;
821         $ok += 4 when $_ > 4;
822         $ok += 8 when $_ < 2.5;
823     }
824     is($ok, 8, "postfix numeric");
825 }
826 {
827     my $ok;
828     given ("apple") {
829         $ok = 1, continue when $_ eq "apple";
830         $ok += 2;
831         $ok = 0 when "banana";
832     }
833     is($ok, 3, "postfix string");
834 }
835 {
836     my $ok;
837     given ("pear") {
838         do { $ok = 1; continue } when /pea/;
839         $ok += 2;
840         $ok = 0 when /pie/;
841         default { $ok += 4 }
842         $ok = 0;
843     }
844     is($ok, 7, "postfix regex");
845 }
846 # be_true is defined at the beginning of the file
847 {
848     my $x = "what";
849     given(my $x = "foo") {
850         do {
851             is($x, "foo", "scope inside ... when my \$x = ...");
852             continue;
853         } when be_true(my $x = "bar");
854         is($x, "bar", "scope after ... when my \$x = ...");
855     }
856 }
857 {
858     my $x = 0;
859     given(my $x = 1) {
860         my $x = 2, continue when be_true();
861         is($x, undef, "scope after my \$x = ... when ...");
862     }
863 }
864
865 # Tests for last and next in when clauses
866 my $letter;
867
868 $letter = '';
869 for ("a".."e") {
870     given ($_) {
871         $letter = $_;
872         when ("b") { last }
873     }
874     $letter = "z";
875 }
876 is($letter, "b", "last in when");
877
878 $letter = '';
879 LETTER1: for ("a".."e") {
880     given ($_) {
881         $letter = $_;
882         when ("b") { last LETTER1 }
883     }
884     $letter = "z";
885 }
886 is($letter, "b", "last LABEL in when");
887
888 $letter = '';
889 for ("a".."e") {
890     given ($_) {
891         when (/b|d/) { next }
892         $letter .= $_;
893     }
894     $letter .= ',';
895 }
896 is($letter, "a,c,e,", "next in when");
897
898 $letter = '';
899 LETTER2: for ("a".."e") {
900     given ($_) {
901         when (/b|d/) { next LETTER2 }
902         $letter .= $_;
903     }
904     $letter .= ',';
905 }
906 is($letter, "a,c,e,", "next LABEL in when");
907
908 # Test goto with given/when
909 {
910     my $flag = 0;
911     goto GIVEN1;
912     $flag = 1;
913     GIVEN1: given ($flag) {
914         when (0) { break; }
915         $flag = 2;
916     }
917     is($flag, 0, "goto GIVEN1");
918 }
919 {
920     my $flag = 0;
921     given ($flag) {
922         when (0) { $flag = 1; }
923         goto GIVEN2;
924         $flag = 2;
925     }
926 GIVEN2:
927     is($flag, 1, "goto inside given");
928 }
929 {
930     my $flag = 0;
931     given ($flag) {
932         when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
933         $flag = 3;
934     }
935 GIVEN3:
936     is($flag, 1, "goto inside given and when");
937 }
938 {
939     my $flag = 0;
940     for ($flag) {
941         when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
942         $flag = 3;
943     }
944 GIVEN4:
945     is($flag, 1, "goto inside for and when");
946 }
947 {
948     my $flag = 0;
949 GIVEN5:
950     given ($flag) {
951         when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
952         when (1) { break; }
953         $flag = 3;
954     }
955     is($flag, 1, "goto inside given and when to the given stmt");
956 }
957
958 # test with unreified @_ in smart match [perl #71078]
959 sub unreified_check { ok([@_] ~~ \@_) } # should always match
960 unreified_check(1,2,"lala");
961 unreified_check(1,2,undef);
962 unreified_check(undef);
963 unreified_check(undef,"");
964
965 # Test do { given } as a rvalue
966
967 {
968     # Simple scalar
969     my $lexical = 5;
970     my @things = (11 .. 26); # 16 elements
971     my @exp = (5, 16, 9);
972     no warnings 'void';
973     for (0, 1, 2) {
974         my $scalar = do { given ($_) {
975             when (0) { $lexical }
976             when (2) { 'void'; 8, 9 }
977             @things;
978         } };
979         is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
980     }
981 }
982 {
983     # Postfix scalar
984     my $lexical = 5;
985     my @exp = (5, 7, 9);
986     for (0, 1, 2) {
987         no warnings 'void';
988         my $scalar = do { given ($_) {
989             $lexical when 0;
990             8, 9     when 2;
991             6, 7;
992         } };
993         is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
994     }
995 }
996 {
997     # Default scalar
998     my @exp = (5, 9, 9);
999     for (0, 1, 2) {
1000         my $scalar = do { given ($_) {
1001             no warnings 'void';
1002             when (0) { 5 }
1003             default  { 8, 9 }
1004             6, 7;
1005         } };
1006         is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
1007     }
1008 }
1009 {
1010     # Simple list
1011     my @things = (11 .. 13);
1012     my @exp = ('3 4 5', '11 12 13', '8 9');
1013     for (0, 1, 2) {
1014         my @list = do { given ($_) {
1015             when (0) { 3 .. 5 }
1016             when (2) { my $fake = 'void'; 8, 9 }
1017             @things;
1018         } };
1019         is("@list", shift(@exp), "rvalue given - simple list [$_]");
1020     }
1021 }
1022 {
1023     # Postfix list
1024     my @things = (12);
1025     my @exp = ('3 4 5', '6 7', '12');
1026     for (0, 1, 2) {
1027         my @list = do { given ($_) {
1028             3 .. 5  when 0;
1029             @things when 2;
1030             6, 7;
1031         } };
1032         is("@list", shift(@exp), "rvalue given - postfix list [$_]");
1033     }
1034 }
1035 {
1036     # Default list
1037     my @things = (11 .. 20); # 10 elements
1038     my @exp = ('m o o', '8 10', '8 10');
1039     for (0, 1, 2) {
1040         my @list = do { given ($_) {
1041             when (0) { "moo" =~ /(.)/g }
1042             default  { 8, scalar(@things) }
1043             6, 7;
1044         } };
1045         is("@list", shift(@exp), "rvalue given - default list [$_]");
1046     }
1047 }
1048 {
1049     # Switch control
1050     my @exp = ('6 7', '', '6 7');
1051     for (0, 1, 2, 3) {
1052         my @list = do { given ($_) {
1053             continue when $_ <= 1;
1054             break    when 1;
1055             next     when 2;
1056             6, 7;
1057         } };
1058         is("@list", shift(@exp), "rvalue given - default list [$_]");
1059     }
1060 }
1061 {
1062     # Context propagation
1063     my $smart_hash = sub {
1064         do { given ($_[0]) {
1065             'undef' when undef;
1066             when ([ 1 .. 3 ]) { 1 .. 3 }
1067             when (4) { my $fake; do { 4, 5 } }
1068         } };
1069     };
1070
1071     my $scalar;
1072
1073     $scalar = $smart_hash->();
1074     is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
1075
1076     $scalar = $smart_hash->(4);
1077     is($scalar, 5,       "rvalue given - scalar context propagation [4]");
1078
1079     $scalar = $smart_hash->(999);
1080     is($scalar, undef,   "rvalue given - scalar context propagation [999]");
1081
1082     my @list;
1083
1084     @list = $smart_hash->();
1085     is("@list", 'undef', "rvalue given - list context propagation [undef]");
1086
1087     @list = $smart_hash->(2);
1088     is("@list", '1 2 3', "rvalue given - list context propagation [2]");
1089
1090     @list = $smart_hash->(4);
1091     is("@list", '4 5',   "rvalue given - list context propagation [4]");
1092
1093     @list = $smart_hash->(999);
1094     is("@list", '',      "rvalue given - list context propagation [999]");
1095 }
1096 {
1097     # Array slices
1098     my @list = 10 .. 15;
1099     my @in_list;
1100     my @in_slice;
1101     for (5, 10, 15) {
1102         given ($_) {
1103             when (@list) {
1104                 push @in_list, $_;
1105                 continue;
1106             }
1107             when (@list[0..2]) {
1108                 push @in_slice, $_;
1109             }
1110         }
1111     }
1112     is("@in_list", "10 15", "when(array)");
1113     is("@in_slice", "10", "when(array slice)");
1114 }
1115 {
1116     # Hash slices
1117     my %list = map { $_ => $_ } "a" .. "f";
1118     my @in_list;
1119     my @in_slice;
1120     for ("a", "e", "i") {
1121         given ($_) {
1122             when (%list) {
1123                 push @in_list, $_;
1124                 continue;
1125             }
1126             when (@list{"a".."c"}) {
1127                 push @in_slice, $_;
1128             }
1129         }
1130     }
1131     is("@in_list", "a e", "when(hash)");
1132     is("@in_slice", "a", "when(hash slice)");
1133 }
1134
1135 { # RT#84526 - Handle magical TARG
1136     my $x = my $y = "aaa";
1137     for ($x, $y) {
1138         given ($_) {
1139             is(pos, undef, "handle magical TARG");
1140             pos = 1;
1141         }
1142     }
1143 }
1144
1145 # Test that returned values are correctly propagated through several context
1146 # levels (see RT #93548).
1147 {
1148     my $tester = sub {
1149         my $id = shift;
1150
1151         package fmurrr;
1152
1153         our ($when_loc, $given_loc, $ext_loc);
1154
1155         my $ext_lex    = 7;
1156         our $ext_glob  = 8;
1157         local $ext_loc = 9;
1158
1159         given ($id) {
1160             my $given_lex    = 4;
1161             our $given_glob  = 5;
1162             local $given_loc = 6;
1163
1164             when (0) { 0 }
1165
1166             when (1) { my $when_lex    = 1 }
1167             when (2) { our $when_glob  = 2 }
1168             when (3) { local $when_loc = 3 }
1169
1170             when (4) { $given_lex }
1171             when (5) { $given_glob }
1172             when (6) { $given_loc }
1173
1174             when (7) { $ext_lex }
1175             when (8) { $ext_glob }
1176             when (9) { $ext_loc }
1177
1178             'fallback';
1179         }
1180     };
1181
1182     my @descriptions = qw<
1183         constant
1184
1185         when-lexical
1186         when-global
1187         when-local
1188
1189         given-lexical
1190         given-global
1191         given-local
1192
1193         extern-lexical
1194         extern-global
1195         extern-local
1196     >;
1197
1198     for my $id (0 .. 9) {
1199         my $desc = $descriptions[$id];
1200
1201         my $res = $tester->($id);
1202         is $res, $id, "plain call - $desc";
1203
1204         $res = do {
1205             my $id_plus_1 = $id + 1;
1206             given ($id_plus_1) {
1207                 do {
1208                     when (/\d/) {
1209                         --$id_plus_1;
1210                         continue;
1211                         456;
1212                     }
1213                 };
1214                 default {
1215                     $tester->($id_plus_1);
1216                 }
1217                 'XXX';
1218             }
1219         };
1220         is $res, $id, "across continue and default - $desc";
1221     }
1222 }
1223
1224 # Check that values returned from given/when are destroyed at the right time.
1225 {
1226     {
1227         package Fmurrr;
1228
1229         sub new {
1230             bless {
1231                 flag => \($_[1]),
1232                 id   => $_[2],
1233             }, $_[0]
1234         }
1235
1236         sub DESTROY {
1237             ${$_[0]->{flag}}++;
1238         }
1239     }
1240
1241     my @descriptions = qw<
1242         when
1243         break
1244         continue
1245         default
1246     >;
1247
1248     for my $id (0 .. 3) {
1249         my $desc = $descriptions[$id];
1250
1251         my $destroyed = 0;
1252         my $res_id;
1253
1254         {
1255             my $res = do {
1256                 given ($id) {
1257                     my $x;
1258                     when (0) { Fmurrr->new($destroyed, 0) }
1259                     when (1) { my $y = Fmurrr->new($destroyed, 1); break }
1260                     when (2) { $x = Fmurrr->new($destroyed, 2); continue }
1261                     when (2) { $x }
1262                     default  { Fmurrr->new($destroyed, 3) }
1263                 }
1264             };
1265             $res_id = $res->{id};
1266         }
1267         $res_id = $id if $id == 1; # break doesn't return anything
1268
1269         is $res_id,    $id, "given/when returns the right object - $desc";
1270         is $destroyed, 1,   "given/when does not leak - $desc";
1271     };
1272 }
1273
1274 # break() must reset the stack
1275 {
1276     my @res = (1, do {
1277         given ("x") {
1278             2, 3, do {
1279                 when (/[a-z]/) {
1280                     4, 5, 6, break
1281                 }
1282             }
1283         }
1284     });
1285     is "@res", "1", "break resets the stack";
1286 }
1287
1288 # RT #94682:
1289 # must ensure $_ is initialised and cleared at start/end of given block
1290
1291 {
1292     package RT94682;
1293
1294     my $d = 0;
1295     sub DESTROY { $d++ };
1296
1297     sub f2 {
1298         local $_ = 5;
1299         given(bless [7]) {
1300             ::is($_->[0], 7, "is [7]");
1301         }
1302         ::is($_, 5, "is 5");
1303         ::is($d, 1, "DESTROY called once");
1304     }
1305     f2();
1306 }
1307
1308 # check that 'when' handles all 'for' loop types
1309
1310 {
1311     my $i;
1312
1313     $i = 0;
1314     for (1..3) {
1315         when (1) {$i +=    1 }
1316         when (2) {$i +=   10 }
1317         when (3) {$i +=  100 }
1318         default { $i += 1000 }
1319     }
1320     is($i, 111, "when in for 1..3");
1321
1322     $i = 0;
1323     for ('a'..'c') {
1324         when ('a') {$i +=    1 }
1325         when ('b') {$i +=   10 }
1326         when ('c') {$i +=  100 }
1327         default { $i += 1000 }
1328     }
1329     is($i, 111, "when in for a..c");
1330
1331     $i = 0;
1332     for (1,2,3) {
1333         when (1) {$i +=    1 }
1334         when (2) {$i +=   10 }
1335         when (3) {$i +=  100 }
1336         default { $i += 1000 }
1337     }
1338     is($i, 111, "when in for 1,2,3");
1339
1340     $i = 0;
1341     my @a = (1,2,3);
1342     for (@a) {
1343         when (1) {$i +=    1 }
1344         when (2) {$i +=   10 }
1345         when (3) {$i +=  100 }
1346         default { $i += 1000 }
1347     }
1348     is($i, 111, 'when in for @a');
1349 }
1350
1351 given("xyz") {
1352     no warnings "void";
1353     my @a = (qw(a b c), do { when(/abc/) { qw(x y) } }, qw(d e f));
1354     is join(",", map { $_ // "u" } @a), "a,b,c,d,e,f",
1355         "list value of false when";
1356     @a = (qw(a b c), scalar do { when(/abc/) { qw(x y) } }, qw(d e f));
1357     is join(",", map { $_ // "u" } @a), "a,b,c,u,d,e,f",
1358         "scalar value of false when";
1359 }
1360
1361 # RT #133368
1362 # index() and rindex() comparisons such as '> -1' are optimised away. Make
1363 # sure that they're still treated as a direct boolean expression rather
1364 # than when(X) being implicitly converted to when($_ ~~ X)
1365
1366 {
1367     my $s = "abc";
1368     my $ok = 0;
1369     given("xyz") {
1370         when (index($s, 'a') > -1) { $ok = 1; }
1371     }
1372     ok($ok, "RT #133368 index");
1373
1374     $ok = 0;
1375     given("xyz") {
1376         when (rindex($s, 'a') > -1) { $ok = 1; }
1377     }
1378     ok($ok, "RT #133368 rindex");
1379 }
1380
1381
1382 # Okay, that'll do for now. The intricacies of the smartmatch
1383 # semantics are tested in t/op/smartmatch.t. Taintedness of
1384 # returned values is checked in t/op/taint.t.
1385 __END__