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