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