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