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