This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make the "..." flip-flop operator work in scalar context in when()
[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
6e03d743 11use Test::More tests => 113;
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{
6e03d743
RGS
513 my $n = 0;
514 for my $l qw(a b c d) {
515 given ($l) {
516 when ($_ eq "b" ... $_ eq "c") { $n = 1 }
517 default { $n = 0 }
518 }
519 ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
520 }
521}
522
523{
1e1d4b91 524 my $ok = 0;
525 given("foo") {
0d863452 526 when((1 == $ok) || "foo") {
1e1d4b91 527 $ok = 1;
0d863452
RH
528 }
529 }
1e1d4b91 530 ok($ok, '((1 == $ok) || "foo") smartmatched');
0d863452
RH
531}
532
f92e1a16
RGS
533{
534 my $ok = 0;
535 given("foo") {
536 when((1 == $ok || undef) // "foo") {
537 $ok = 1;
538 }
539 }
540 ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
541}
542
0d863452
RH
543# Make sure we aren't invoking the get-magic more than once
544
545{ # A helper class to count the number of accesses.
546 package FetchCounter;
547 sub TIESCALAR {
548 my ($class) = @_;
549 bless {value => undef, count => 0}, $class;
550 }
551 sub STORE {
552 my ($self, $val) = @_;
553 $self->{count} = 0;
554 $self->{value} = $val;
555 }
556 sub FETCH {
557 my ($self) = @_;
558 # Avoid pre/post increment here
559 $self->{count} = 1 + $self->{count};
560 $self->{value};
561 }
562 sub count {
563 my ($self) = @_;
564 $self->{count};
565 }
566}
567
568my $f = tie my $v, "FetchCounter";
569
570{ my $test_name = "Only one FETCH (in given)";
cd9c531b 571 my $ok;
0d863452
RH
572 given($v = 23) {
573 when(undef) {}
574 when(sub{0}->()) {}
575 when(21) {}
576 when("22") {}
577 when(23) {$ok = 1}
578 when(/24/) {$ok = 0}
579 }
cd9c531b 580 is($ok, 1, "precheck: $test_name");
0d863452
RH
581 is($f->count(), 1, $test_name);
582}
583
584{ my $test_name = "Only one FETCH (numeric when)";
cd9c531b 585 my $ok;
0d863452
RH
586 $v = 23;
587 is($f->count(), 0, "Sanity check: $test_name");
588 given(23) {
589 when(undef) {}
590 when(sub{0}->()) {}
591 when(21) {}
592 when("22") {}
593 when($v) {$ok = 1}
594 when(/24/) {$ok = 0}
595 }
cd9c531b 596 is($ok, 1, "precheck: $test_name");
0d863452
RH
597 is($f->count(), 1, $test_name);
598}
599
600{ my $test_name = "Only one FETCH (string when)";
cd9c531b 601 my $ok;
0d863452
RH
602 $v = "23";
603 is($f->count(), 0, "Sanity check: $test_name");
604 given("23") {
605 when(undef) {}
606 when(sub{0}->()) {}
607 when("21") {}
608 when("22") {}
609 when($v) {$ok = 1}
610 when(/24/) {$ok = 0}
611 }
cd9c531b 612 is($ok, 1, "precheck: $test_name");
0d863452
RH
613 is($f->count(), 1, $test_name);
614}
615
616{ my $test_name = "Only one FETCH (undef)";
cd9c531b 617 my $ok;
0d863452
RH
618 $v = undef;
619 is($f->count(), 0, "Sanity check: $test_name");
620 given(my $undef) {
621 when(sub{0}->()) {}
622 when("21") {}
623 when("22") {}
624 when($v) {$ok = 1}
625 when(undef) {$ok = 0}
626 }
cd9c531b 627 is($ok, 1, "precheck: $test_name");
0d863452
RH
628 is($f->count(), 1, $test_name);
629}
630
631# Loop topicalizer
632{
633 my $first = 1;
634 for (1, "two") {
635 when ("two") {
636 is($first, 0, "Loop: second");
637 eval {break};
638 like($@, qr/^Can't "break" in a loop topicalizer/,
639 q{Can't "break" in a loop topicalizer});
640 }
641 when (1) {
642 is($first, 1, "Loop: first");
643 $first = 0;
644 # Implicit break is okay
645 }
646 }
647}
648
649{
650 my $first = 1;
651 for $_ (1, "two") {
652 when ("two") {
653 is($first, 0, "Explicit \$_: second");
654 eval {break};
655 like($@, qr/^Can't "break" in a loop topicalizer/,
656 q{Can't "break" in a loop topicalizer});
657 }
658 when (1) {
659 is($first, 1, "Explicit \$_: first");
660 $first = 0;
661 # Implicit break is okay
662 }
663 }
664}
665
666{
667 my $first = 1;
668 my $_;
669 for (1, "two") {
670 when ("two") {
671 is($first, 0, "Implicitly lexical loop: second");
672 eval {break};
673 like($@, qr/^Can't "break" in a loop topicalizer/,
674 q{Can't "break" in a loop topicalizer});
675 }
676 when (1) {
677 is($first, 1, "Implicitly lexical loop: first");
678 $first = 0;
679 # Implicit break is okay
680 }
681 }
682}
683
684{
685 my $first = 1;
686 my $_;
687 for $_ (1, "two") {
688 when ("two") {
689 is($first, 0, "Implicitly lexical, explicit \$_: second");
690 eval {break};
691 like($@, qr/^Can't "break" in a loop topicalizer/,
692 q{Can't "break" in a loop topicalizer});
693 }
694 when (1) {
695 is($first, 1, "Implicitly lexical, explicit \$_: first");
696 $first = 0;
697 # Implicit break is okay
698 }
699 }
700}
701
702{
703 my $first = 1;
704 for my $_ (1, "two") {
705 when ("two") {
706 is($first, 0, "Lexical loop: second");
707 eval {break};
708 like($@, qr/^Can't "break" in a loop topicalizer/,
709 q{Can't "break" in a loop topicalizer});
710 }
711 when (1) {
1dcb720a 712 is($first, 1, "Lexical loop: first");
0d863452
RH
713 $first = 0;
714 # Implicit break is okay
715 }
716 }
717}
718
719
720# Code references
721{
722 no warnings "redefine";
723 my $called_foo = 0;
724 sub foo {$called_foo = 1}
725 my $called_bar = 0;
726 sub bar {$called_bar = 1}
727 my ($matched_foo, $matched_bar) = (0, 0);
728 given(\&foo) {
729 when(\&bar) {$matched_bar = 1}
730 when(\&foo) {$matched_foo = 1}
731 }
732 is($called_foo, 0, "Code ref comparison: foo not called");
733 is($called_bar, 0, "Code ref comparison: bar not called");
734 is($matched_bar, 0, "Code ref didn't match different one");
735 is($matched_foo, 1, "Code ref did match itself");
736}
737
738sub contains_x {
739 my $x = shift;
740 return ($x =~ /x/);
741}
742{
743 my ($ok1, $ok2) = (0,0);
744 given("foxy!") {
745 when(contains_x($_))
746 { $ok1 = 1; continue }
747 when(\&contains_x)
748 { $ok2 = 1; continue }
749 }
750 is($ok1, 1, "Calling sub directly (true)");
751 is($ok2, 1, "Calling sub indirectly (true)");
752
753 given("foggy") {
754 when(contains_x($_))
755 { $ok1 = 2; continue }
756 when(\&contains_x)
757 { $ok2 = 2; continue }
758 }
759 is($ok1, 1, "Calling sub directly (false)");
760 is($ok2, 1, "Calling sub indirectly (false)");
761}
762
02eafbe2
DD
763SKIP: {
764 skip "Scalar/Util.pm not yet available", 20
765 unless -r "$INC[0]/Scalar/Util.pm";
766 # Test overloading
767 { package OverloadTest;
768
769 use overload '""' => sub{"string value of obj"};
770
771 use overload "~~" => sub {
772 my ($self, $other, $reversed) = @_;
773 if ($reversed) {
774 $self->{left} = $other;
775 $self->{right} = $self;
776 $self->{reversed} = 1;
777 } else {
778 $self->{left} = $self;
779 $self->{right} = $other;
780 $self->{reversed} = 0;
781 }
782 $self->{called} = 1;
783 return $self->{retval};
784 };
0d863452 785
02eafbe2
DD
786 sub new {
787 my ($pkg, $retval) = @_;
788 bless {
789 called => 0,
790 retval => $retval,
791 }, $pkg;
792 }
793 }
794
795 {
796 my $test = "Overloaded obj in given (true)";
797 my $obj = OverloadTest->new(1);
798 my $matched;
799 given($obj) {
800 when ("other arg") {$matched = 1}
801 default {$matched = 0}
802 }
0d863452 803
02eafbe2
DD
804 is($obj->{called}, 1, "$test: called");
805 ok($matched, "$test: matched");
806 is($obj->{left}, "string value of obj", "$test: left");
807 is($obj->{right}, "other arg", "$test: right");
808 ok(!$obj->{reversed}, "$test: not reversed");
809 }
810
811 {
812 my $test = "Overloaded obj in given (false)";
813 my $obj = OverloadTest->new(0);
814 my $matched;
815 given($obj) {
816 when ("other arg") {$matched = 1}
817 }
0d863452 818
02eafbe2
DD
819 is($obj->{called}, 1, "$test: called");
820 ok(!$matched, "$test: not matched");
821 is($obj->{left}, "string value of obj", "$test: left");
822 is($obj->{right}, "other arg", "$test: right");
823 ok(!$obj->{reversed}, "$test: not reversed");
824 }
825
826 {
827 my $test = "Overloaded obj in when (true)";
828 my $obj = OverloadTest->new(1);
829 my $matched;
830 given("topic") {
831 when ($obj) {$matched = 1}
832 default {$matched = 0}
833 }
0d863452 834
02eafbe2
DD
835 is($obj->{called}, 1, "$test: called");
836 ok($matched, "$test: matched");
837 is($obj->{left}, "topic", "$test: left");
838 is($obj->{right}, "string value of obj", "$test: right");
839 ok($obj->{reversed}, "$test: reversed");
840 }
841
842 {
843 my $test = "Overloaded obj in when (false)";
844 my $obj = OverloadTest->new(0);
845 my $matched;
846 given("topic") {
847 when ($obj) {$matched = 1}
848 default {$matched = 0}
849 }
0d863452 850
02eafbe2
DD
851 is($obj->{called}, 1, "$test: called");
852 ok(!$matched, "$test: not matched");
853 is($obj->{left}, "topic", "$test: left");
854 is($obj->{right}, "string value of obj", "$test: right");
855 ok($obj->{reversed}, "$test: reversed");
856 }
0d863452 857}
0d863452
RH
858# Okay, that'll do for now. The intricacies of the smartmatch
859# semantics are tested in t/op/smartmatch.t
860__END__