This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge branch 'nobangs' into blead
[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
37e07c40 12plan tests => 122;
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
416# File tests
417# (How to be both thorough and portable? Pinch a few ideas
418# from t/op/filetest.t. We err on the side of portability for
419# the time being.)
420
421{
422 my ($ok_d, $ok_f, $ok_r);
423 given("op") {
424 when(-d) {$ok_d = 1; continue}
425 when(!-f) {$ok_f = 1; continue}
426 when(-r) {$ok_r = 1; continue}
427 }
428 ok($ok_d, "Filetest -d");
429 ok($ok_f, "Filetest -f");
430 ok($ok_r, "Filetest -r");
431}
432
433# Sub and method calls
84c82fbf 434sub notfoo {"bar"}
0d863452
RH
435{
436 my $ok = 0;
437 given("foo") {
84c82fbf 438 when(notfoo()) {$ok = 1}
0d863452
RH
439 }
440 ok($ok, "Sub call acts as boolean")
441}
442
443{
444 my $ok = 0;
445 given("foo") {
84c82fbf 446 when(main->notfoo()) {$ok = 1}
0d863452
RH
447 }
448 ok($ok, "Class-method call acts as boolean")
449}
450
451{
452 my $ok = 0;
453 my $obj = bless [];
454 given("foo") {
84c82fbf 455 when($obj->notfoo()) {$ok = 1}
0d863452
RH
456 }
457 ok($ok, "Object-method call acts as boolean")
458}
459
460# Other things that should not be smart matched
461{
462 my $ok = 0;
1e1d4b91 463 given(12) {
464 when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
465 $ok = 1;
466 }
467 }
468 ok($ok, "bool not smartmatches");
469}
470
471{
472 my $ok = 0;
0d863452
RH
473 given(0) {
474 when(eof(DATA)) {
475 $ok = 1;
476 }
477 }
478 ok($ok, "eof() not smartmatched");
479}
480
481{
482 my $ok = 0;
483 my %foo = ("bar", 0);
484 given(0) {
485 when(exists $foo{bar}) {
486 $ok = 1;
487 }
488 }
489 ok($ok, "exists() not smartmatched");
490}
491
492{
493 my $ok = 0;
494 given(0) {
495 when(defined $ok) {
496 $ok = 1;
497 }
498 }
499 ok($ok, "defined() not smartmatched");
500}
501
502{
503 my $ok = 1;
504 given("foo") {
505 when((1 == 1) && "bar") {
506 $ok = 0;
507 }
508 when((1 == 1) && $_ eq "foo") {
509 $ok = 2;
510 }
511 }
512 is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
513}
514
515{
6e03d743
RGS
516 my $n = 0;
517 for my $l qw(a b c d) {
518 given ($l) {
f118ea0d
RGS
519 when ($_ eq "b" .. $_ eq "c") { $n = 1 }
520 default { $n = 0 }
521 }
522 ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
523 }
524}
525
526{
527 my $n = 0;
528 for my $l qw(a b c d) {
529 given ($l) {
6e03d743
RGS
530 when ($_ eq "b" ... $_ eq "c") { $n = 1 }
531 default { $n = 0 }
532 }
533 ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
534 }
535}
536
537{
1e1d4b91 538 my $ok = 0;
539 given("foo") {
0d863452 540 when((1 == $ok) || "foo") {
1e1d4b91 541 $ok = 1;
0d863452
RH
542 }
543 }
1e1d4b91 544 ok($ok, '((1 == $ok) || "foo") smartmatched');
0d863452
RH
545}
546
f92e1a16
RGS
547{
548 my $ok = 0;
549 given("foo") {
550 when((1 == $ok || undef) // "foo") {
551 $ok = 1;
552 }
553 }
554 ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
555}
556
0d863452
RH
557# Make sure we aren't invoking the get-magic more than once
558
559{ # A helper class to count the number of accesses.
560 package FetchCounter;
561 sub TIESCALAR {
562 my ($class) = @_;
563 bless {value => undef, count => 0}, $class;
564 }
565 sub STORE {
566 my ($self, $val) = @_;
567 $self->{count} = 0;
568 $self->{value} = $val;
569 }
570 sub FETCH {
571 my ($self) = @_;
572 # Avoid pre/post increment here
573 $self->{count} = 1 + $self->{count};
574 $self->{value};
575 }
576 sub count {
577 my ($self) = @_;
578 $self->{count};
579 }
580}
581
582my $f = tie my $v, "FetchCounter";
583
584{ my $test_name = "Only one FETCH (in given)";
cd9c531b 585 my $ok;
0d863452
RH
586 given($v = 23) {
587 when(undef) {}
588 when(sub{0}->()) {}
589 when(21) {}
590 when("22") {}
591 when(23) {$ok = 1}
592 when(/24/) {$ok = 0}
593 }
cd9c531b 594 is($ok, 1, "precheck: $test_name");
0d863452
RH
595 is($f->count(), 1, $test_name);
596}
597
598{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b 599 my $ok;
0d863452
RH
600 $v = 23;
601 is($f->count(), 0, "Sanity check: $test_name");
602 given(23) {
603 when(undef) {}
604 when(sub{0}->()) {}
605 when(21) {}
606 when("22") {}
607 when($v) {$ok = 1}
608 when(/24/) {$ok = 0}
609 }
cd9c531b 610 is($ok, 1, "precheck: $test_name");
0d863452
RH
611 is($f->count(), 1, $test_name);
612}
613
614{ my $test_name = "Only one FETCH (string when)";
cd9c531b 615 my $ok;
0d863452
RH
616 $v = "23";
617 is($f->count(), 0, "Sanity check: $test_name");
618 given("23") {
619 when(undef) {}
620 when(sub{0}->()) {}
621 when("21") {}
622 when("22") {}
623 when($v) {$ok = 1}
624 when(/24/) {$ok = 0}
625 }
cd9c531b 626 is($ok, 1, "precheck: $test_name");
0d863452
RH
627 is($f->count(), 1, $test_name);
628}
629
630{ my $test_name = "Only one FETCH (undef)";
cd9c531b 631 my $ok;
0d863452
RH
632 $v = undef;
633 is($f->count(), 0, "Sanity check: $test_name");
62ec5f58 634 no warnings "uninitialized";
0d863452
RH
635 given(my $undef) {
636 when(sub{0}->()) {}
637 when("21") {}
638 when("22") {}
639 when($v) {$ok = 1}
640 when(undef) {$ok = 0}
641 }
cd9c531b 642 is($ok, 1, "precheck: $test_name");
0d863452
RH
643 is($f->count(), 1, $test_name);
644}
645
646# Loop topicalizer
647{
648 my $first = 1;
649 for (1, "two") {
650 when ("two") {
651 is($first, 0, "Loop: second");
652 eval {break};
653 like($@, qr/^Can't "break" in a loop topicalizer/,
654 q{Can't "break" in a loop topicalizer});
655 }
656 when (1) {
657 is($first, 1, "Loop: first");
658 $first = 0;
659 # Implicit break is okay
660 }
661 }
662}
663
664{
665 my $first = 1;
666 for $_ (1, "two") {
667 when ("two") {
668 is($first, 0, "Explicit \$_: 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, "Explicit \$_: first");
675 $first = 0;
676 # Implicit break is okay
677 }
678 }
679}
680
681{
682 my $first = 1;
683 my $_;
684 for (1, "two") {
685 when ("two") {
686 is($first, 0, "Implicitly lexical loop: second");
687 eval {break};
688 like($@, qr/^Can't "break" in a loop topicalizer/,
689 q{Can't "break" in a loop topicalizer});
690 }
691 when (1) {
692 is($first, 1, "Implicitly lexical loop: first");
693 $first = 0;
694 # Implicit break is okay
695 }
696 }
697}
698
699{
700 my $first = 1;
701 my $_;
702 for $_ (1, "two") {
703 when ("two") {
704 is($first, 0, "Implicitly lexical, explicit \$_: second");
705 eval {break};
706 like($@, qr/^Can't "break" in a loop topicalizer/,
707 q{Can't "break" in a loop topicalizer});
708 }
709 when (1) {
710 is($first, 1, "Implicitly lexical, explicit \$_: first");
711 $first = 0;
712 # Implicit break is okay
713 }
714 }
715}
716
717{
718 my $first = 1;
719 for my $_ (1, "two") {
720 when ("two") {
721 is($first, 0, "Lexical loop: 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) {
1dcb720a 727 is($first, 1, "Lexical loop: first");
0d863452
RH
728 $first = 0;
729 # Implicit break is okay
730 }
731 }
732}
733
734
735# Code references
736{
0d863452 737 my $called_foo = 0;
84c82fbf 738 sub foo {$called_foo = 1; "@_" eq "foo"}
0d863452 739 my $called_bar = 0;
84c82fbf 740 sub bar {$called_bar = 1; "@_" eq "bar"}
0d863452 741 my ($matched_foo, $matched_bar) = (0, 0);
84c82fbf 742 given("foo") {
0d863452
RH
743 when(\&bar) {$matched_bar = 1}
744 when(\&foo) {$matched_foo = 1}
745 }
84c82fbf
RGS
746 is($called_foo, 1, "foo() was called");
747 is($called_bar, 1, "bar() was called");
748 is($matched_bar, 0, "bar didn't match");
749 is($matched_foo, 1, "foo did match");
0d863452
RH
750}
751
752sub contains_x {
753 my $x = shift;
754 return ($x =~ /x/);
755}
756{
757 my ($ok1, $ok2) = (0,0);
758 given("foxy!") {
759 when(contains_x($_))
760 { $ok1 = 1; continue }
761 when(\&contains_x)
762 { $ok2 = 1; continue }
763 }
764 is($ok1, 1, "Calling sub directly (true)");
765 is($ok2, 1, "Calling sub indirectly (true)");
766
767 given("foggy") {
768 when(contains_x($_))
769 { $ok1 = 2; continue }
770 when(\&contains_x)
771 { $ok2 = 2; continue }
772 }
773 is($ok1, 1, "Calling sub directly (false)");
774 is($ok2, 1, "Calling sub indirectly (false)");
775}
776
02eafbe2
DD
777SKIP: {
778 skip "Scalar/Util.pm not yet available", 20
779 unless -r "$INC[0]/Scalar/Util.pm";
780 # Test overloading
781 { package OverloadTest;
782
783 use overload '""' => sub{"string value of obj"};
6d743019 784 use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
02eafbe2
DD
785
786 use overload "~~" => sub {
787 my ($self, $other, $reversed) = @_;
788 if ($reversed) {
789 $self->{left} = $other;
790 $self->{right} = $self;
791 $self->{reversed} = 1;
792 } else {
793 $self->{left} = $self;
794 $self->{right} = $other;
795 $self->{reversed} = 0;
796 }
797 $self->{called} = 1;
798 return $self->{retval};
799 };
0d863452 800
02eafbe2
DD
801 sub new {
802 my ($pkg, $retval) = @_;
803 bless {
804 called => 0,
805 retval => $retval,
806 }, $pkg;
807 }
808 }
809
810 {
811 my $test = "Overloaded obj in given (true)";
812 my $obj = OverloadTest->new(1);
813 my $matched;
814 given($obj) {
815 when ("other arg") {$matched = 1}
816 default {$matched = 0}
817 }
0d863452 818
2cb9bde7
RGS
819 is($obj->{called}, 1, "$test: called");
820 ok($matched, "$test: matched");
02eafbe2
DD
821 }
822
823 {
824 my $test = "Overloaded obj in given (false)";
825 my $obj = OverloadTest->new(0);
826 my $matched;
827 given($obj) {
828 when ("other arg") {$matched = 1}
829 }
0d863452 830
2cb9bde7 831 is($obj->{called}, 1, "$test: called");
02eafbe2 832 ok(!$matched, "$test: not matched");
02eafbe2
DD
833 }
834
835 {
836 my $test = "Overloaded obj in when (true)";
837 my $obj = OverloadTest->new(1);
838 my $matched;
839 given("topic") {
840 when ($obj) {$matched = 1}
841 default {$matched = 0}
842 }
0d863452 843
02eafbe2
DD
844 is($obj->{called}, 1, "$test: called");
845 ok($matched, "$test: matched");
846 is($obj->{left}, "topic", "$test: left");
847 is($obj->{right}, "string value of obj", "$test: right");
848 ok($obj->{reversed}, "$test: reversed");
849 }
850
851 {
852 my $test = "Overloaded obj in when (false)";
853 my $obj = OverloadTest->new(0);
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: not 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 }
0d863452 866}
f20dcd76
VP
867
868# Postfix when
869{
870 my $ok;
871 given (undef) {
872 $ok = 1 when undef;
873 }
874 is($ok, 1, "postfix undef");
875}
876{
877 my $ok;
878 given (2) {
879 $ok += 1 when 7;
880 $ok += 2 when 9.1685;
881 $ok += 4 when $_ > 4;
882 $ok += 8 when $_ < 2.5;
883 }
884 is($ok, 8, "postfix numeric");
885}
886{
887 my $ok;
888 given ("apple") {
889 $ok = 1, continue when $_ eq "apple";
890 $ok += 2;
891 $ok = 0 when "banana";
892 }
893 is($ok, 3, "postfix string");
894}
895{
896 my $ok;
897 given ("pear") {
898 do { $ok = 1; continue } when /pea/;
899 $ok += 2;
900 $ok = 0 when /pie/;
901 default { $ok += 4 }
902 $ok = 0;
903 }
904 is($ok, 7, "postfix regex");
905}
906# be_true is defined at the beginning of the file
907{
908 my $x = "what";
909 given(my $x = "foo") {
910 do {
911 is($x, "foo", "scope inside ... when my \$x = ...");
912 continue;
913 } when be_true(my $x = "bar");
914 is($x, "bar", "scope after ... when my \$x = ...");
915 }
916}
917{
918 my $x = 0;
919 given(my $x = 1) {
920 my $x = 2, continue when be_true();
921 is($x, undef, "scope after my \$x = ... when ...");
922 }
923}
924
1ebfab32
RGS
925# Tests for last and next in when clauses
926my $letter;
927
928$letter = '';
929for ("a".."e") {
930 given ($_) {
931 $letter = $_;
932 when ("b") { last }
933 }
934 $letter = "z";
935}
936is($letter, "b", "last in when");
937
938$letter = '';
939LETTER1: for ("a".."e") {
940 given ($_) {
941 $letter = $_;
942 when ("b") { last LETTER1 }
943 }
944 $letter = "z";
945}
946is($letter, "b", "last LABEL in when");
947
948$letter = '';
949for ("a".."e") {
950 given ($_) {
951 when (/b|d/) { next }
952 $letter .= $_;
953 }
954 $letter .= ',';
955}
956is($letter, "a,c,e,", "next in when");
957
958$letter = '';
959LETTER2: for ("a".."e") {
960 given ($_) {
961 when (/b|d/) { next LETTER2 }
962 $letter .= $_;
963 }
964 $letter .= ',';
965}
966is($letter, "a,c,e,", "next LABEL in when");
f20dcd76 967
0d863452
RH
968# Okay, that'll do for now. The intricacies of the smartmatch
969# semantics are tested in t/op/smartmatch.t
970__END__