This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix RT #77468: Smart matching on slices
[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
25b991bf 12plan tests => 160;
0d863452
RH
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.
0d863452
RH
17
18use feature 'switch';
0d863452
RH
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{
cd9c531b 60 my $ok;
0d863452 61 given(3) {
cd9c531b
NC
62 when(2) { $ok = 'two'; }
63 when(3) { $ok = 'three'; }
64 when(4) { $ok = 'four'; }
65 default { $ok = 'd'; }
0d863452 66 }
cd9c531b 67 is($ok, 'three', "numeric comparison");
0d863452
RH
68}
69
70{
cd9c531b 71 my $ok;
0d863452
RH
72 use integer;
73 given(3.14159265) {
cd9c531b
NC
74 when(2) { $ok = 'two'; }
75 when(3) { $ok = 'three'; }
76 when(4) { $ok = 'four'; }
77 default { $ok = 'd'; }
0d863452 78 }
cd9c531b 79 is($ok, 'three', "integer comparison");
0d863452
RH
80}
81
82{
cd9c531b 83 my ($ok1, $ok2);
0d863452 84 given(3) {
cd9c531b
NC
85 when(3.1) { $ok1 = 'n'; }
86 when(3.0) { $ok1 = 'y'; continue }
87 when("3.0") { $ok2 = 'y'; }
88 default { $ok2 = 'n'; }
0d863452 89 }
cd9c531b
NC
90 is($ok1, 'y', "more numeric (pt. 1)");
91 is($ok2, 'y', "more numeric (pt. 2)");
0d863452
RH
92}
93
94{
cd9c531b 95 my $ok;
0d863452 96 given("c") {
cd9c531b
NC
97 when("b") { $ok = 'B'; }
98 when("c") { $ok = 'C'; }
99 when("d") { $ok = 'D'; }
100 default { $ok = 'def'; }
0d863452 101 }
cd9c531b 102 is($ok, 'C', "string comparison");
0d863452
RH
103}
104
105{
cd9c531b 106 my $ok;
0d863452 107 given("c") {
cd9c531b
NC
108 when("b") { $ok = 'B'; }
109 when("c") { $ok = 'C'; continue }
110 when("c") { $ok = 'CC'; }
111 default { $ok = 'D'; }
0d863452 112 }
cd9c531b 113 is($ok, 'CC', "simple continue");
0d863452
RH
114}
115
116# Definedness
117{
118 my $ok = 1;
119 given (0) { when(undef) {$ok = 0} }
cd9c531b 120 is($ok, 1, "Given(0) when(undef)");
0d863452
RH
121}
122{
123 my $undef;
124 my $ok = 1;
125 given (0) { when($undef) {$ok = 0} }
cd9c531b 126 is($ok, 1, 'Given(0) when($undef)');
0d863452
RH
127}
128{
129 my $undef;
130 my $ok = 0;
131 given (0) { when($undef++) {$ok = 1} }
cd9c531b 132 is($ok, 1, "Given(0) when($undef++)");
0d863452
RH
133}
134{
62ec5f58 135 no warnings "uninitialized";
fb51372e
RGS
136 my $ok = 1;
137 given (undef) { when(0) {$ok = 0} }
cd9c531b 138 is($ok, 1, "Given(undef) when(0)");
0d863452
RH
139}
140{
62ec5f58 141 no warnings "uninitialized";
0d863452 142 my $undef;
fb51372e
RGS
143 my $ok = 1;
144 given ($undef) { when(0) {$ok = 0} }
cd9c531b 145 is($ok, 1, 'Given($undef) when(0)');
0d863452
RH
146}
147########
148{
149 my $ok = 1;
150 given ("") { when(undef) {$ok = 0} }
cd9c531b 151 is($ok, 1, 'Given("") when(undef)');
0d863452
RH
152}
153{
154 my $undef;
155 my $ok = 1;
156 given ("") { when($undef) {$ok = 0} }
cd9c531b 157 is($ok, 1, 'Given("") when($undef)');
0d863452
RH
158}
159{
62ec5f58 160 no warnings "uninitialized";
fb51372e
RGS
161 my $ok = 1;
162 given (undef) { when("") {$ok = 0} }
cd9c531b 163 is($ok, 1, 'Given(undef) when("")');
0d863452
RH
164}
165{
62ec5f58 166 no warnings "uninitialized";
0d863452 167 my $undef;
fb51372e
RGS
168 my $ok = 1;
169 given ($undef) { when("") {$ok = 0} }
cd9c531b 170 is($ok, 1, 'Given($undef) when("")');
0d863452
RH
171}
172########
173{
174 my $ok = 0;
175 given (undef) { when(undef) {$ok = 1} }
cd9c531b 176 is($ok, 1, "Given(undef) when(undef)");
0d863452
RH
177}
178{
179 my $undef;
180 my $ok = 0;
181 given (undef) { when($undef) {$ok = 1} }
cd9c531b 182 is($ok, 1, 'Given(undef) when($undef)');
0d863452
RH
183}
184{
185 my $undef;
186 my $ok = 0;
187 given ($undef) { when(undef) {$ok = 1} }
cd9c531b 188 is($ok, 1, 'Given($undef) when(undef)');
0d863452
RH
189}
190{
191 my $undef;
192 my $ok = 0;
193 given ($undef) { when($undef) {$ok = 1} }
cd9c531b 194 is($ok, 1, 'Given($undef) when($undef)');
0d863452
RH
195}
196
197
198# Regular expressions
199{
cd9c531b 200 my ($ok1, $ok2);
0d863452
RH
201 given("Hello, world!") {
202 when(/lo/)
cd9c531b 203 { $ok1 = 'y'; continue}
0d863452 204 when(/no/)
cd9c531b 205 { $ok1 = 'n'; continue}
0d863452 206 when(/^(Hello,|Goodbye cruel) world[!.?]/)
cd9c531b 207 { $ok2 = 'Y'; continue}
0d863452 208 when(/^(Hello cruel|Goodbye,) world[!.?]/)
cd9c531b 209 { $ok2 = 'n'; continue}
0d863452 210 }
cd9c531b
NC
211 is($ok1, 'y', "regex 1");
212 is($ok2, 'Y', "regex 2");
0d863452
RH
213}
214
215# Comparisons
216{
217 my $test = "explicit numeric comparison (<)";
218 my $twenty_five = 25;
cd9c531b 219 my $ok;
0d863452 220 given($twenty_five) {
cd9c531b
NC
221 when ($_ < 10) { $ok = "ten" }
222 when ($_ < 20) { $ok = "twenty" }
223 when ($_ < 30) { $ok = "thirty" }
224 when ($_ < 40) { $ok = "forty" }
225 default { $ok = "default" }
0d863452 226 }
cd9c531b 227 is($ok, "thirty", $test);
0d863452
RH
228}
229
230{
231 use integer;
232 my $test = "explicit numeric comparison (integer <)";
233 my $twenty_five = 25;
cd9c531b 234 my $ok;
0d863452 235 given($twenty_five) {
cd9c531b
NC
236 when ($_ < 10) { $ok = "ten" }
237 when ($_ < 20) { $ok = "twenty" }
238 when ($_ < 30) { $ok = "thirty" }
239 when ($_ < 40) { $ok = "forty" }
240 default { $ok = "default" }
0d863452 241 }
cd9c531b 242 is($ok, "thirty", $test);
0d863452
RH
243}
244
245{
246 my $test = "explicit numeric comparison (<=)";
247 my $twenty_five = 25;
cd9c531b 248 my $ok;
0d863452 249 given($twenty_five) {
cd9c531b
NC
250 when ($_ <= 10) { $ok = "ten" }
251 when ($_ <= 20) { $ok = "twenty" }
252 when ($_ <= 30) { $ok = "thirty" }
253 when ($_ <= 40) { $ok = "forty" }
254 default { $ok = "default" }
0d863452 255 }
cd9c531b 256 is($ok, "thirty", $test);
0d863452
RH
257}
258
259{
260 use integer;
261 my $test = "explicit numeric comparison (integer <=)";
262 my $twenty_five = 25;
cd9c531b 263 my $ok;
0d863452 264 given($twenty_five) {
cd9c531b
NC
265 when ($_ <= 10) { $ok = "ten" }
266 when ($_ <= 20) { $ok = "twenty" }
267 when ($_ <= 30) { $ok = "thirty" }
268 when ($_ <= 40) { $ok = "forty" }
269 default { $ok = "default" }
0d863452 270 }
cd9c531b 271 is($ok, "thirty", $test);
0d863452
RH
272}
273
274
275{
276 my $test = "explicit numeric comparison (>)";
277 my $twenty_five = 25;
cd9c531b 278 my $ok;
0d863452 279 given($twenty_five) {
cd9c531b
NC
280 when ($_ > 40) { $ok = "forty" }
281 when ($_ > 30) { $ok = "thirty" }
282 when ($_ > 20) { $ok = "twenty" }
283 when ($_ > 10) { $ok = "ten" }
284 default { $ok = "default" }
0d863452 285 }
cd9c531b 286 is($ok, "twenty", $test);
0d863452
RH
287}
288
289{
290 my $test = "explicit numeric comparison (>=)";
291 my $twenty_five = 25;
cd9c531b 292 my $ok;
0d863452 293 given($twenty_five) {
cd9c531b
NC
294 when ($_ >= 40) { $ok = "forty" }
295 when ($_ >= 30) { $ok = "thirty" }
296 when ($_ >= 20) { $ok = "twenty" }
297 when ($_ >= 10) { $ok = "ten" }
298 default { $ok = "default" }
0d863452 299 }
cd9c531b 300 is($ok, "twenty", $test);
0d863452
RH
301}
302
303{
304 use integer;
305 my $test = "explicit numeric comparison (integer >)";
306 my $twenty_five = 25;
cd9c531b 307 my $ok;
0d863452 308 given($twenty_five) {
cd9c531b
NC
309 when ($_ > 40) { $ok = "forty" }
310 when ($_ > 30) { $ok = "thirty" }
311 when ($_ > 20) { $ok = "twenty" }
312 when ($_ > 10) { $ok = "ten" }
313 default { $ok = "default" }
0d863452 314 }
cd9c531b 315 is($ok, "twenty", $test);
0d863452
RH
316}
317
318{
319 use integer;
320 my $test = "explicit numeric comparison (integer >=)";
321 my $twenty_five = 25;
cd9c531b 322 my $ok;
0d863452 323 given($twenty_five) {
cd9c531b
NC
324 when ($_ >= 40) { $ok = "forty" }
325 when ($_ >= 30) { $ok = "thirty" }
326 when ($_ >= 20) { $ok = "twenty" }
327 when ($_ >= 10) { $ok = "ten" }
328 default { $ok = "default" }
0d863452 329 }
cd9c531b 330 is($ok, "twenty", $test);
0d863452
RH
331}
332
333
334{
335 my $test = "explicit string comparison (lt)";
336 my $twenty_five = "25";
cd9c531b 337 my $ok;
0d863452 338 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 344 }
cd9c531b 345 is($ok, "thirty", $test);
0d863452
RH
346}
347
348{
349 my $test = "explicit string comparison (le)";
350 my $twenty_five = "25";
cd9c531b 351 my $ok;
0d863452 352 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 358 }
cd9c531b 359 is($ok, "thirty", $test);
0d863452
RH
360}
361
362{
363 my $test = "explicit string comparison (gt)";
364 my $twenty_five = 25;
cd9c531b 365 my $ok;
0d863452 366 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 372 }
cd9c531b 373 is($ok, "twenty", $test);
0d863452
RH
374}
375
376{
377 my $test = "explicit string comparison (ge)";
378 my $twenty_five = 25;
cd9c531b 379 my $ok;
0d863452 380 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 386 }
cd9c531b 387 is($ok, "twenty", $test);
0d863452
RH
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;
cd9c531b 395 my $ok;
0d863452 396 given($twenty_five) {
cd9c531b
NC
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" }
0d863452 402 }
cd9c531b 403 is($ok, "twenty", $test);
0d863452
RH
404}
405
406# Optimized-away comparisons
407{
cd9c531b 408 my $ok;
0d863452 409 given(23) {
cd9c531b
NC
410 when (2 + 2 == 4) { $ok = 'y'; continue }
411 when (2 + 2 == 5) { $ok = 'n' }
0d863452 412 }
cd9c531b 413 is($ok, 'y', "Optimized-away comparison");
0d863452
RH
414}
415
5341b2b7
JJ
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
0d863452
RH
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
84c82fbf 443sub notfoo {"bar"}
0d863452
RH
444{
445 my $ok = 0;
446 given("foo") {
84c82fbf 447 when(notfoo()) {$ok = 1}
0d863452
RH
448 }
449 ok($ok, "Sub call acts as boolean")
450}
451
452{
453 my $ok = 0;
454 given("foo") {
84c82fbf 455 when(main->notfoo()) {$ok = 1}
0d863452
RH
456 }
457 ok($ok, "Class-method call acts as boolean")
458}
459
460{
461 my $ok = 0;
462 my $obj = bless [];
463 given("foo") {
84c82fbf 464 when($obj->notfoo()) {$ok = 1}
0d863452
RH
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;
1e1d4b91 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;
0d863452
RH
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{
6e03d743
RGS
525 my $n = 0;
526 for my $l qw(a b c d) {
527 given ($l) {
f118ea0d
RGS
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) {
6e03d743
RGS
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{
1e1d4b91 547 my $ok = 0;
548 given("foo") {
0d863452 549 when((1 == $ok) || "foo") {
1e1d4b91 550 $ok = 1;
0d863452
RH
551 }
552 }
1e1d4b91 553 ok($ok, '((1 == $ok) || "foo") smartmatched');
0d863452
RH
554}
555
f92e1a16
RGS
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
0d863452
RH
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)";
cd9c531b 594 my $ok;
0d863452
RH
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 }
cd9c531b 603 is($ok, 1, "precheck: $test_name");
0d863452
RH
604 is($f->count(), 1, $test_name);
605}
606
607{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b 608 my $ok;
0d863452
RH
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 }
cd9c531b 619 is($ok, 1, "precheck: $test_name");
0d863452
RH
620 is($f->count(), 1, $test_name);
621}
622
623{ my $test_name = "Only one FETCH (string when)";
cd9c531b 624 my $ok;
0d863452
RH
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 }
cd9c531b 635 is($ok, 1, "precheck: $test_name");
0d863452
RH
636 is($f->count(), 1, $test_name);
637}
638
639{ my $test_name = "Only one FETCH (undef)";
cd9c531b 640 my $ok;
0d863452
RH
641 $v = undef;
642 is($f->count(), 0, "Sanity check: $test_name");
62ec5f58 643 no warnings "uninitialized";
0d863452
RH
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 }
cd9c531b 651 is($ok, 1, "precheck: $test_name");
0d863452
RH
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) {
1dcb720a 736 is($first, 1, "Lexical loop: first");
0d863452
RH
737 $first = 0;
738 # Implicit break is okay
739 }
740 }
741}
742
743
744# Code references
745{
0d863452 746 my $called_foo = 0;
84c82fbf 747 sub foo {$called_foo = 1; "@_" eq "foo"}
0d863452 748 my $called_bar = 0;
84c82fbf 749 sub bar {$called_bar = 1; "@_" eq "bar"}
0d863452 750 my ($matched_foo, $matched_bar) = (0, 0);
84c82fbf 751 given("foo") {
0d863452
RH
752 when(\&bar) {$matched_bar = 1}
753 when(\&foo) {$matched_foo = 1}
754 }
84c82fbf
RGS
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");
0d863452
RH
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
02eafbe2
DD
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"};
6d743019 793 use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
02eafbe2
DD
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 };
0d863452 809
02eafbe2
DD
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 }
0d863452 827
2cb9bde7
RGS
828 is($obj->{called}, 1, "$test: called");
829 ok($matched, "$test: matched");
02eafbe2
DD
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 }
0d863452 839
2cb9bde7 840 is($obj->{called}, 1, "$test: called");
02eafbe2 841 ok(!$matched, "$test: not matched");
02eafbe2
DD
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 }
0d863452 852
02eafbe2
DD
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 }
0d863452 868
02eafbe2
DD
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 }
0d863452 875}
f20dcd76
VP
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
1ebfab32
RGS
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");
f20dcd76 976
bb5aedc1
VP
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
69c3dccf
RGS
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
25b991bf
VP
1034# Test do { given } as a rvalue
1035
1036{
1037 # Simple scalar
1038 my $lexical = 5;
1039 my @things = (11 .. 26); # 16 elements
1040 my @exp = (5, 16, 9);
1041 no warnings 'void';
1042 for (0, 1, 2) {
1043 my $scalar = do { given ($_) {
1044 when (0) { $lexical }
1045 when (2) { 'void'; 8, 9 }
1046 @things;
1047 } };
1048 is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
1049 }
1050}
1051{
1052 # Postfix scalar
1053 my $lexical = 5;
1054 my @exp = (5, 7, 9);
1055 for (0, 1, 2) {
1056 no warnings 'void';
1057 my $scalar = do { given ($_) {
1058 $lexical when 0;
1059 8, 9 when 2;
1060 6, 7;
1061 } };
1062 is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
1063 }
1064}
1065{
1066 # Default scalar
1067 my @exp = (5, 9, 9);
1068 for (0, 1, 2) {
1069 my $scalar = do { given ($_) {
1070 no warnings 'void';
1071 when (0) { 5 }
1072 default { 8, 9 }
1073 6, 7;
1074 } };
1075 is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
1076 }
1077}
1078{
1079 # Simple list
1080 my @things = (11 .. 13);
1081 my @exp = ('3 4 5', '11 12 13', '8 9');
1082 for (0, 1, 2) {
1083 my @list = do { given ($_) {
1084 when (0) { 3 .. 5 }
1085 when (2) { my $fake = 'void'; 8, 9 }
1086 @things;
1087 } };
1088 is("@list", shift(@exp), "rvalue given - simple list [$_]");
1089 }
1090}
1091{
1092 # Postfix list
1093 my @things = (12);
1094 my @exp = ('3 4 5', '6 7', '12');
1095 for (0, 1, 2) {
1096 my @list = do { given ($_) {
1097 3 .. 5 when 0;
1098 @things when 2;
1099 6, 7;
1100 } };
1101 is("@list", shift(@exp), "rvalue given - postfix list [$_]");
1102 }
1103}
1104{
1105 # Default list
1106 my @things = (11 .. 20); # 10 elements
1107 my @exp = ('m o o', '8 10', '8 10');
1108 for (0, 1, 2) {
1109 my @list = do { given ($_) {
1110 when (0) { "moo" =~ /(.)/g }
1111 default { 8, scalar(@things) }
1112 6, 7;
1113 } };
1114 is("@list", shift(@exp), "rvalue given - default list [$_]");
1115 }
1116}
1117{
1118 # Switch control
1119 my @exp = ('6 7', '', '6 7');
1120 for (0, 1, 2, 3) {
1121 my @list = do { given ($_) {
1122 continue when $_ <= 1;
1123 break when 1;
1124 next when 2;
1125 6, 7;
1126 } };
1127 is("@list", shift(@exp), "rvalue given - default list [$_]");
1128 }
1129}
1130{
1131 # Context propagation
1132 my $smart_hash = sub {
1133 do { given ($_[0]) {
1134 'undef' when undef;
1135 when ([ 1 .. 3 ]) { 1 .. 3 }
1136 when (4) { my $fake; do { 4, 5 } }
1137 } };
1138 };
1139
1140 my $scalar;
1141
1142 $scalar = $smart_hash->();
1143 is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
1144
1145 $scalar = $smart_hash->(4);
1146 is($scalar, 5, "rvalue given - scalar context propagation [4]");
1147
1148 $scalar = $smart_hash->(999);
1149 is($scalar, undef, "rvalue given - scalar context propagation [999]");
1150
1151 my @list;
1152
1153 @list = $smart_hash->();
1154 is("@list", 'undef', "rvalue given - list context propagation [undef]");
1155
1156 @list = $smart_hash->(2);
1157 is("@list", '1 2 3', "rvalue given - list context propagation [2]");
1158
1159 @list = $smart_hash->(4);
1160 is("@list", '4 5', "rvalue given - list context propagation [4]");
1161
1162 @list = $smart_hash->(999);
1163 is("@list", '', "rvalue given - list context propagation [999]");
1164}
1165
0d863452
RH
1166# Okay, that'll do for now. The intricacies of the smartmatch
1167# semantics are tested in t/op/smartmatch.t
1168__END__