This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #114020, #90018, #53186] Make given alias $_
[perl5.git] / t / op / switch.t
CommitLineData
0d863452
RH
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
37e07c40 6 require './test.pl';
0d863452
RH
7}
8
9use strict;
10use warnings;
11
87e4a53a 12plan tests => 201;
0d863452 13
a632cb9b
FC
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
0d863452 16# the switch ops themselves.
0d863452 17
9dcb8368
FC
18
19# Before loading feature, test the switch ops with CORE::
20CORE::given(3) {
a5c70c4d
FC
21 CORE::when(3) { pass "CORE::given and CORE::when"; continue }
22 CORE::default { pass "continue (without feature) and CORE::default" }
9dcb8368
FC
23}
24
25
0d863452 26use feature 'switch';
0d863452
RH
27
28eval { continue };
29like($@, qr/^Can't "continue" outside/, "continue outside");
30
31eval { break };
32like($@, 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
44sub be_true {1}
45
46given(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";
54given("inside") { check_outside1() }
b5a64814 55sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
0d863452
RH
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{
cd9c531b 68 my $ok;
0d863452 69 given(3) {
cd9c531b
NC
70 when(2) { $ok = 'two'; }
71 when(3) { $ok = 'three'; }
72 when(4) { $ok = 'four'; }
73 default { $ok = 'd'; }
0d863452 74 }
cd9c531b 75 is($ok, 'three', "numeric comparison");
0d863452
RH
76}
77
78{
cd9c531b 79 my $ok;
0d863452
RH
80 use integer;
81 given(3.14159265) {
cd9c531b
NC
82 when(2) { $ok = 'two'; }
83 when(3) { $ok = 'three'; }
84 when(4) { $ok = 'four'; }
85 default { $ok = 'd'; }
0d863452 86 }
cd9c531b 87 is($ok, 'three', "integer comparison");
0d863452
RH
88}
89
90{
cd9c531b 91 my ($ok1, $ok2);
0d863452 92 given(3) {
cd9c531b
NC
93 when(3.1) { $ok1 = 'n'; }
94 when(3.0) { $ok1 = 'y'; continue }
95 when("3.0") { $ok2 = 'y'; }
96 default { $ok2 = 'n'; }
0d863452 97 }
cd9c531b
NC
98 is($ok1, 'y', "more numeric (pt. 1)");
99 is($ok2, 'y', "more numeric (pt. 2)");
0d863452
RH
100}
101
102{
cd9c531b 103 my $ok;
0d863452 104 given("c") {
cd9c531b
NC
105 when("b") { $ok = 'B'; }
106 when("c") { $ok = 'C'; }
107 when("d") { $ok = 'D'; }
108 default { $ok = 'def'; }
0d863452 109 }
cd9c531b 110 is($ok, 'C', "string comparison");
0d863452
RH
111}
112
113{
cd9c531b 114 my $ok;
0d863452 115 given("c") {
cd9c531b
NC
116 when("b") { $ok = 'B'; }
117 when("c") { $ok = 'C'; continue }
118 when("c") { $ok = 'CC'; }
119 default { $ok = 'D'; }
0d863452 120 }
cd9c531b 121 is($ok, 'CC', "simple continue");
0d863452
RH
122}
123
124# Definedness
125{
126 my $ok = 1;
127 given (0) { when(undef) {$ok = 0} }
cd9c531b 128 is($ok, 1, "Given(0) when(undef)");
0d863452
RH
129}
130{
131 my $undef;
132 my $ok = 1;
133 given (0) { when($undef) {$ok = 0} }
cd9c531b 134 is($ok, 1, 'Given(0) when($undef)');
0d863452
RH
135}
136{
137 my $undef;
138 my $ok = 0;
139 given (0) { when($undef++) {$ok = 1} }
cd9c531b 140 is($ok, 1, "Given(0) when($undef++)");
0d863452
RH
141}
142{
62ec5f58 143 no warnings "uninitialized";
fb51372e
RGS
144 my $ok = 1;
145 given (undef) { when(0) {$ok = 0} }
cd9c531b 146 is($ok, 1, "Given(undef) when(0)");
0d863452
RH
147}
148{
62ec5f58 149 no warnings "uninitialized";
0d863452 150 my $undef;
fb51372e
RGS
151 my $ok = 1;
152 given ($undef) { when(0) {$ok = 0} }
cd9c531b 153 is($ok, 1, 'Given($undef) when(0)');
0d863452
RH
154}
155########
156{
157 my $ok = 1;
158 given ("") { when(undef) {$ok = 0} }
cd9c531b 159 is($ok, 1, 'Given("") when(undef)');
0d863452
RH
160}
161{
162 my $undef;
163 my $ok = 1;
164 given ("") { when($undef) {$ok = 0} }
cd9c531b 165 is($ok, 1, 'Given("") when($undef)');
0d863452
RH
166}
167{
62ec5f58 168 no warnings "uninitialized";
fb51372e
RGS
169 my $ok = 1;
170 given (undef) { when("") {$ok = 0} }
cd9c531b 171 is($ok, 1, 'Given(undef) when("")');
0d863452
RH
172}
173{
62ec5f58 174 no warnings "uninitialized";
0d863452 175 my $undef;
fb51372e
RGS
176 my $ok = 1;
177 given ($undef) { when("") {$ok = 0} }
cd9c531b 178 is($ok, 1, 'Given($undef) when("")');
0d863452
RH
179}
180########
181{
182 my $ok = 0;
183 given (undef) { when(undef) {$ok = 1} }
cd9c531b 184 is($ok, 1, "Given(undef) when(undef)");
0d863452
RH
185}
186{
187 my $undef;
188 my $ok = 0;
189 given (undef) { when($undef) {$ok = 1} }
cd9c531b 190 is($ok, 1, 'Given(undef) when($undef)');
0d863452
RH
191}
192{
193 my $undef;
194 my $ok = 0;
195 given ($undef) { when(undef) {$ok = 1} }
cd9c531b 196 is($ok, 1, 'Given($undef) when(undef)');
0d863452
RH
197}
198{
199 my $undef;
200 my $ok = 0;
201 given ($undef) { when($undef) {$ok = 1} }
cd9c531b 202 is($ok, 1, 'Given($undef) when($undef)');
0d863452
RH
203}
204
205
206# Regular expressions
207{
cd9c531b 208 my ($ok1, $ok2);
0d863452
RH
209 given("Hello, world!") {
210 when(/lo/)
cd9c531b 211 { $ok1 = 'y'; continue}
0d863452 212 when(/no/)
cd9c531b 213 { $ok1 = 'n'; continue}
0d863452 214 when(/^(Hello,|Goodbye cruel) world[!.?]/)
cd9c531b 215 { $ok2 = 'Y'; continue}
0d863452 216 when(/^(Hello cruel|Goodbye,) world[!.?]/)
cd9c531b 217 { $ok2 = 'n'; continue}
0d863452 218 }
cd9c531b
NC
219 is($ok1, 'y', "regex 1");
220 is($ok2, 'Y', "regex 2");
0d863452
RH
221}
222
223# Comparisons
224{
225 my $test = "explicit numeric comparison (<)";
226 my $twenty_five = 25;
cd9c531b 227 my $ok;
0d863452 228 given($twenty_five) {
cd9c531b
NC
229 when ($_ < 10) { $ok = "ten" }
230 when ($_ < 20) { $ok = "twenty" }
231 when ($_ < 30) { $ok = "thirty" }
232 when ($_ < 40) { $ok = "forty" }
233 default { $ok = "default" }
0d863452 234 }
cd9c531b 235 is($ok, "thirty", $test);
0d863452
RH
236}
237
238{
239 use integer;
240 my $test = "explicit numeric comparison (integer <)";
241 my $twenty_five = 25;
cd9c531b 242 my $ok;
0d863452 243 given($twenty_five) {
cd9c531b
NC
244 when ($_ < 10) { $ok = "ten" }
245 when ($_ < 20) { $ok = "twenty" }
246 when ($_ < 30) { $ok = "thirty" }
247 when ($_ < 40) { $ok = "forty" }
248 default { $ok = "default" }
0d863452 249 }
cd9c531b 250 is($ok, "thirty", $test);
0d863452
RH
251}
252
253{
254 my $test = "explicit numeric comparison (<=)";
255 my $twenty_five = 25;
cd9c531b 256 my $ok;
0d863452 257 given($twenty_five) {
cd9c531b
NC
258 when ($_ <= 10) { $ok = "ten" }
259 when ($_ <= 20) { $ok = "twenty" }
260 when ($_ <= 30) { $ok = "thirty" }
261 when ($_ <= 40) { $ok = "forty" }
262 default { $ok = "default" }
0d863452 263 }
cd9c531b 264 is($ok, "thirty", $test);
0d863452
RH
265}
266
267{
268 use integer;
269 my $test = "explicit numeric comparison (integer <=)";
270 my $twenty_five = 25;
cd9c531b 271 my $ok;
0d863452 272 given($twenty_five) {
cd9c531b
NC
273 when ($_ <= 10) { $ok = "ten" }
274 when ($_ <= 20) { $ok = "twenty" }
275 when ($_ <= 30) { $ok = "thirty" }
276 when ($_ <= 40) { $ok = "forty" }
277 default { $ok = "default" }
0d863452 278 }
cd9c531b 279 is($ok, "thirty", $test);
0d863452
RH
280}
281
282
283{
284 my $test = "explicit numeric comparison (>)";
285 my $twenty_five = 25;
cd9c531b 286 my $ok;
0d863452 287 given($twenty_five) {
cd9c531b
NC
288 when ($_ > 40) { $ok = "forty" }
289 when ($_ > 30) { $ok = "thirty" }
290 when ($_ > 20) { $ok = "twenty" }
291 when ($_ > 10) { $ok = "ten" }
292 default { $ok = "default" }
0d863452 293 }
cd9c531b 294 is($ok, "twenty", $test);
0d863452
RH
295}
296
297{
298 my $test = "explicit numeric comparison (>=)";
299 my $twenty_five = 25;
cd9c531b 300 my $ok;
0d863452 301 given($twenty_five) {
cd9c531b
NC
302 when ($_ >= 40) { $ok = "forty" }
303 when ($_ >= 30) { $ok = "thirty" }
304 when ($_ >= 20) { $ok = "twenty" }
305 when ($_ >= 10) { $ok = "ten" }
306 default { $ok = "default" }
0d863452 307 }
cd9c531b 308 is($ok, "twenty", $test);
0d863452
RH
309}
310
311{
312 use integer;
313 my $test = "explicit numeric comparison (integer >)";
314 my $twenty_five = 25;
cd9c531b 315 my $ok;
0d863452 316 given($twenty_five) {
cd9c531b
NC
317 when ($_ > 40) { $ok = "forty" }
318 when ($_ > 30) { $ok = "thirty" }
319 when ($_ > 20) { $ok = "twenty" }
320 when ($_ > 10) { $ok = "ten" }
321 default { $ok = "default" }
0d863452 322 }
cd9c531b 323 is($ok, "twenty", $test);
0d863452
RH
324}
325
326{
327 use integer;
328 my $test = "explicit numeric comparison (integer >=)";
329 my $twenty_five = 25;
cd9c531b 330 my $ok;
0d863452 331 given($twenty_five) {
cd9c531b
NC
332 when ($_ >= 40) { $ok = "forty" }
333 when ($_ >= 30) { $ok = "thirty" }
334 when ($_ >= 20) { $ok = "twenty" }
335 when ($_ >= 10) { $ok = "ten" }
336 default { $ok = "default" }
0d863452 337 }
cd9c531b 338 is($ok, "twenty", $test);
0d863452
RH
339}
340
341
342{
343 my $test = "explicit string comparison (lt)";
344 my $twenty_five = "25";
cd9c531b 345 my $ok;
0d863452 346 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 352 }
cd9c531b 353 is($ok, "thirty", $test);
0d863452
RH
354}
355
356{
357 my $test = "explicit string comparison (le)";
358 my $twenty_five = "25";
cd9c531b 359 my $ok;
0d863452 360 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 366 }
cd9c531b 367 is($ok, "thirty", $test);
0d863452
RH
368}
369
370{
371 my $test = "explicit string comparison (gt)";
372 my $twenty_five = 25;
cd9c531b 373 my $ok;
0d863452 374 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 380 }
cd9c531b 381 is($ok, "twenty", $test);
0d863452
RH
382}
383
384{
385 my $test = "explicit string comparison (ge)";
386 my $twenty_five = 25;
cd9c531b 387 my $ok;
0d863452 388 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 394 }
cd9c531b 395 is($ok, "twenty", $test);
0d863452
RH
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;
cd9c531b 403 my $ok;
0d863452 404 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 410 }
cd9c531b 411 is($ok, "twenty", $test);
0d863452
RH
412}
413
414# Optimized-away comparisons
415{
cd9c531b 416 my $ok;
0d863452 417 given(23) {
cd9c531b
NC
418 when (2 + 2 == 4) { $ok = 'y'; continue }
419 when (2 + 2 == 5) { $ok = 'n' }
0d863452 420 }
cd9c531b 421 is($ok, 'y', "Optimized-away comparison");
0d863452
RH
422}
423
5341b2b7
JJ
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
0d863452
RH
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
84c82fbf 451sub notfoo {"bar"}
0d863452
RH
452{
453 my $ok = 0;
454 given("foo") {
84c82fbf 455 when(notfoo()) {$ok = 1}
0d863452
RH
456 }
457 ok($ok, "Sub call acts as boolean")
458}
459
460{
461 my $ok = 0;
462 given("foo") {
84c82fbf 463 when(main->notfoo()) {$ok = 1}
0d863452
RH
464 }
465 ok($ok, "Class-method call acts as boolean")
466}
467
468{
469 my $ok = 0;
470 my $obj = bless [];
471 given("foo") {
84c82fbf 472 when($obj->notfoo()) {$ok = 1}
0d863452
RH
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;
1e1d4b91 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;
0d863452
RH
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{
6e03d743 533 my $n = 0;
ea25a9b2 534 for my $l (qw(a b c d)) {
6e03d743 535 given ($l) {
f118ea0d
RGS
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;
ea25a9b2 545 for my $l (qw(a b c d)) {
f118ea0d 546 given ($l) {
6e03d743
RGS
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{
1e1d4b91 555 my $ok = 0;
556 given("foo") {
0d863452 557 when((1 == $ok) || "foo") {
1e1d4b91 558 $ok = 1;
0d863452
RH
559 }
560 }
1e1d4b91 561 ok($ok, '((1 == $ok) || "foo") smartmatched');
0d863452
RH
562}
563
f92e1a16
RGS
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
0d863452
RH
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
599my $f = tie my $v, "FetchCounter";
600
b5a64814 601{ my $test_name = "Multiple FETCHes in given, due to aliasing";
cd9c531b 602 my $ok;
0d863452
RH
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 }
cd9c531b 611 is($ok, 1, "precheck: $test_name");
b5a64814 612 is($f->count(), 4, $test_name);
0d863452
RH
613}
614
615{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b 616 my $ok;
0d863452
RH
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 }
cd9c531b 627 is($ok, 1, "precheck: $test_name");
0d863452
RH
628 is($f->count(), 1, $test_name);
629}
630
631{ my $test_name = "Only one FETCH (string when)";
cd9c531b 632 my $ok;
0d863452
RH
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 }
cd9c531b 643 is($ok, 1, "precheck: $test_name");
0d863452
RH
644 is($f->count(), 1, $test_name);
645}
646
647{ my $test_name = "Only one FETCH (undef)";
cd9c531b 648 my $ok;
0d863452
RH
649 $v = undef;
650 is($f->count(), 0, "Sanity check: $test_name");
62ec5f58 651 no warnings "uninitialized";
0d863452
RH
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 }
cd9c531b 659 is($ok, 1, "precheck: $test_name");
0d863452
RH
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) {
1dcb720a 744 is($first, 1, "Lexical loop: first");
0d863452
RH
745 $first = 0;
746 # Implicit break is okay
747 }
748 }
749}
750
751
752# Code references
753{
0d863452 754 my $called_foo = 0;
84c82fbf 755 sub foo {$called_foo = 1; "@_" eq "foo"}
0d863452 756 my $called_bar = 0;
84c82fbf 757 sub bar {$called_bar = 1; "@_" eq "bar"}
0d863452 758 my ($matched_foo, $matched_bar) = (0, 0);
84c82fbf 759 given("foo") {
0d863452
RH
760 when(\&bar) {$matched_bar = 1}
761 when(\&foo) {$matched_foo = 1}
762 }
84c82fbf
RGS
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");
0d863452
RH
767}
768
769sub 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
02eafbe2 794SKIP: {
f6e0b6da 795 skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
02eafbe2
DD
796 # Test overloading
797 { package OverloadTest;
798
799 use overload '""' => sub{"string value of obj"};
6d743019 800 use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
02eafbe2
DD
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 };
0d863452 816
02eafbe2
DD
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 }
0d863452 834
2cb9bde7
RGS
835 is($obj->{called}, 1, "$test: called");
836 ok($matched, "$test: matched");
02eafbe2
DD
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 }
0d863452 846
2cb9bde7 847 is($obj->{called}, 1, "$test: called");
02eafbe2 848 ok(!$matched, "$test: not matched");
02eafbe2
DD
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 }
0d863452 859
02eafbe2
DD
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 }
0d863452 875
02eafbe2
DD
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 }
0d863452 882}
f20dcd76
VP
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
1ebfab32
RGS
941# Tests for last and next in when clauses
942my $letter;
943
944$letter = '';
945for ("a".."e") {
946 given ($_) {
947 $letter = $_;
948 when ("b") { last }
949 }
950 $letter = "z";
951}
952is($letter, "b", "last in when");
953
954$letter = '';
955LETTER1: for ("a".."e") {
956 given ($_) {
957 $letter = $_;
958 when ("b") { last LETTER1 }
959 }
960 $letter = "z";
961}
962is($letter, "b", "last LABEL in when");
963
964$letter = '';
965for ("a".."e") {
966 given ($_) {
967 when (/b|d/) { next }
968 $letter .= $_;
969 }
970 $letter .= ',';
971}
972is($letter, "a,c,e,", "next in when");
973
974$letter = '';
975LETTER2: for ("a".."e") {
976 given ($_) {
977 when (/b|d/) { next LETTER2 }
978 $letter .= $_;
979 }
980 $letter .= ',';
981}
982is($letter, "a,c,e,", "next LABEL in when");
f20dcd76 983
bb5aedc1
VP
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 }
1002GIVEN2:
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 }
1011GIVEN3:
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 }
1020GIVEN4:
1021 is($flag, 1, "goto inside for and when");
1022}
1023{
1024 my $flag = 0;
1025GIVEN5:
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
69c3dccf
RGS
1034# test with unreified @_ in smart match [perl #71078]
1035sub unreified_check { ok([@_] ~~ \@_) } # should always match
1036unreified_check(1,2,"lala");
1037unreified_check(1,2,undef);
1038unreified_check(undef);
1039unreified_check(undef,"");
1040
25b991bf
VP
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}
87f718f1
RGS
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}
25b991bf 1210
fad0c757 1211{ # RT#84526 - Handle magical TARG
fad0c757
EB
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
c08f093b
VP
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
0787ea8a
VP
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
87e4a53a
DM
1364# RT #94682:
1365# must ensure $_ is initialised and cleared at start/end of given block
1366
1367{
1368 sub f1 {
b5a64814 1369 my $_;
87e4a53a
DM
1370 given(3) {
1371 return sub { $_ } # close over lexical $_
1372 }
1373 }
1374 is(f1()->(), 3, 'closed over $_');
1375
1376 package RT94682;
1377
1378 my $d = 0;
1379 sub DESTROY { $d++ };
1380
1381 sub f2 {
1382 my $_ = 5;
1383 given(bless [7]) {
1384 ::is($_->[0], 7, "is [7]");
1385 }
1386 ::is($_, 5, "is 5");
1387 ::is($d, 1, "DESTROY called once");
1388 }
1389 f2();
1390}
1391
1392
1393
0d863452 1394# Okay, that'll do for now. The intricacies of the smartmatch
fa22d357
VP
1395# semantics are tested in t/op/smartmatch.t. Taintedness of
1396# returned values is checked in t/op/taint.t.
0d863452 1397__END__