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