[perl #50538] when( @n && %n ) fails to smart match
[perl.git] / t / op / switch.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
7
8 use strict;
9 use warnings;
10
11 use Test::More tests => 111;
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
18 use feature 'switch';
19 no warnings "numeric";
20
21 eval { continue };
22 like($@, qr/^Can't "continue" outside/, "continue outside");
23
24 eval { break };
25 like($@, 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
37 sub be_true {1}
38
39 given(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";
47 given("inside") { check_outside1() }
48 sub 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 {    
61     my $ok;
62     given(3) {
63         when(2) { $ok = 'two'; }
64         when(3) { $ok = 'three'; }
65         when(4) { $ok = 'four'; }
66         default { $ok = 'd'; }
67     }
68     is($ok, 'three', "numeric comparison");
69 }
70
71 {    
72     my $ok;
73     use integer;
74     given(3.14159265) {
75         when(2) { $ok = 'two'; }
76         when(3) { $ok = 'three'; }
77         when(4) { $ok = 'four'; }
78         default { $ok = 'd'; }
79     }
80     is($ok, 'three', "integer comparison");
81 }
82
83 {    
84     my ($ok1, $ok2);
85     given(3) {
86         when(3.1)   { $ok1 = 'n'; }
87         when(3.0)   { $ok1 = 'y'; continue }
88         when("3.0") { $ok2 = 'y'; }
89         default     { $ok2 = 'n'; }
90     }
91     is($ok1, 'y', "more numeric (pt. 1)");
92     is($ok2, 'y', "more numeric (pt. 2)");
93 }
94
95 {
96     my $ok;
97     given("c") {
98         when("b") { $ok = 'B'; }
99         when("c") { $ok = 'C'; }
100         when("d") { $ok = 'D'; }
101         default   { $ok = 'def'; }
102     }
103     is($ok, 'C', "string comparison");
104 }
105
106 {
107     my $ok;
108     given("c") {
109         when("b") { $ok = 'B'; }
110         when("c") { $ok = 'C'; continue }
111         when("c") { $ok = 'CC'; }
112         default   { $ok = 'D'; }
113     }
114     is($ok, 'CC', "simple continue");
115 }
116
117 # Definedness
118 {
119     my $ok = 1;
120     given (0) { when(undef) {$ok = 0} }
121     is($ok, 1, "Given(0) when(undef)");
122 }
123 {
124     my $undef;
125     my $ok = 1;
126     given (0) { when($undef) {$ok = 0} }
127     is($ok, 1, 'Given(0) when($undef)');
128 }
129 {
130     my $undef;
131     my $ok = 0;
132     given (0) { when($undef++) {$ok = 1} }
133     is($ok, 1, "Given(0) when($undef++)");
134 }
135 {
136     my $ok = 1;
137     given (undef) { when(0) {$ok = 0} }
138     is($ok, 1, "Given(undef) when(0)");
139 }
140 {
141     my $undef;
142     my $ok = 1;
143     given ($undef) { when(0) {$ok = 0} }
144     is($ok, 1, 'Given($undef) when(0)');
145 }
146 ########
147 {
148     my $ok = 1;
149     given ("") { when(undef) {$ok = 0} }
150     is($ok, 1, 'Given("") when(undef)');
151 }
152 {
153     my $undef;
154     my $ok = 1;
155     given ("") { when($undef) {$ok = 0} }
156     is($ok, 1, 'Given("") when($undef)');
157 }
158 {
159     my $ok = 1;
160     given (undef) { when("") {$ok = 0} }
161     is($ok, 1, 'Given(undef) when("")');
162 }
163 {
164     my $undef;
165     my $ok = 1;
166     given ($undef) { when("") {$ok = 0} }
167     is($ok, 1, 'Given($undef) when("")');
168 }
169 ########
170 {
171     my $ok = 0;
172     given (undef) { when(undef) {$ok = 1} }
173     is($ok, 1, "Given(undef) when(undef)");
174 }
175 {
176     my $undef;
177     my $ok = 0;
178     given (undef) { when($undef) {$ok = 1} }
179     is($ok, 1, 'Given(undef) when($undef)');
180 }
181 {
182     my $undef;
183     my $ok = 0;
184     given ($undef) { when(undef) {$ok = 1} }
185     is($ok, 1, 'Given($undef) when(undef)');
186 }
187 {
188     my $undef;
189     my $ok = 0;
190     given ($undef) { when($undef) {$ok = 1} }
191     is($ok, 1, 'Given($undef) when($undef)');
192 }
193
194
195 # Regular expressions
196 {
197     my ($ok1, $ok2);
198     given("Hello, world!") {
199         when(/lo/)
200             { $ok1 = 'y'; continue}
201         when(/no/)
202             { $ok1 = 'n'; continue}
203         when(/^(Hello,|Goodbye cruel) world[!.?]/)
204             { $ok2 = 'Y'; continue}
205         when(/^(Hello cruel|Goodbye,) world[!.?]/)
206             { $ok2 = 'n'; continue}
207     }
208     is($ok1, 'y', "regex 1");
209     is($ok2, 'Y', "regex 2");
210 }
211
212 # Comparisons
213 {
214     my $test = "explicit numeric comparison (<)";
215     my $twenty_five = 25;
216     my $ok;
217     given($twenty_five) {
218         when ($_ < 10) { $ok = "ten" }
219         when ($_ < 20) { $ok = "twenty" }
220         when ($_ < 30) { $ok = "thirty" }
221         when ($_ < 40) { $ok = "forty" }
222         default        { $ok = "default" }
223     }
224     is($ok, "thirty", $test);
225 }
226
227 {
228     use integer;
229     my $test = "explicit numeric comparison (integer <)";
230     my $twenty_five = 25;
231     my $ok;
232     given($twenty_five) {
233         when ($_ < 10) { $ok = "ten" }
234         when ($_ < 20) { $ok = "twenty" }
235         when ($_ < 30) { $ok = "thirty" }
236         when ($_ < 40) { $ok = "forty" }
237         default        { $ok = "default" }
238     }
239     is($ok, "thirty", $test);
240 }
241
242 {
243     my $test = "explicit numeric comparison (<=)";
244     my $twenty_five = 25;
245     my $ok;
246     given($twenty_five) {
247         when ($_ <= 10) { $ok = "ten" }
248         when ($_ <= 20) { $ok = "twenty" }
249         when ($_ <= 30) { $ok = "thirty" }
250         when ($_ <= 40) { $ok = "forty" }
251         default         { $ok = "default" }
252     }
253     is($ok, "thirty", $test);
254 }
255
256 {
257     use integer;
258     my $test = "explicit numeric comparison (integer <=)";
259     my $twenty_five = 25;
260     my $ok;
261     given($twenty_five) {
262         when ($_ <= 10) { $ok = "ten" }
263         when ($_ <= 20) { $ok = "twenty" }
264         when ($_ <= 30) { $ok = "thirty" }
265         when ($_ <= 40) { $ok = "forty" }
266         default         { $ok = "default" }
267     }
268     is($ok, "thirty", $test);
269 }
270
271
272 {
273     my $test = "explicit numeric comparison (>)";
274     my $twenty_five = 25;
275     my $ok;
276     given($twenty_five) {
277         when ($_ > 40) { $ok = "forty" }
278         when ($_ > 30) { $ok = "thirty" }
279         when ($_ > 20) { $ok = "twenty" }
280         when ($_ > 10) { $ok = "ten" }
281         default        { $ok = "default" }
282     }
283     is($ok, "twenty", $test);
284 }
285
286 {
287     my $test = "explicit numeric comparison (>=)";
288     my $twenty_five = 25;
289     my $ok;
290     given($twenty_five) {
291         when ($_ >= 40) { $ok = "forty" }
292         when ($_ >= 30) { $ok = "thirty" }
293         when ($_ >= 20) { $ok = "twenty" }
294         when ($_ >= 10) { $ok = "ten" }
295         default         { $ok = "default" }
296     }
297     is($ok, "twenty", $test);
298 }
299
300 {
301     use integer;
302     my $test = "explicit numeric comparison (integer >)";
303     my $twenty_five = 25;
304     my $ok;
305     given($twenty_five) {
306         when ($_ > 40) { $ok = "forty" }
307         when ($_ > 30) { $ok = "thirty" }
308         when ($_ > 20) { $ok = "twenty" }
309         when ($_ > 10) { $ok = "ten" }
310         default        { $ok = "default" }
311     }
312     is($ok, "twenty", $test);
313 }
314
315 {
316     use integer;
317     my $test = "explicit numeric comparison (integer >=)";
318     my $twenty_five = 25;
319     my $ok;
320     given($twenty_five) {
321         when ($_ >= 40) { $ok = "forty" }
322         when ($_ >= 30) { $ok = "thirty" }
323         when ($_ >= 20) { $ok = "twenty" }
324         when ($_ >= 10) { $ok = "ten" }
325         default         { $ok = "default" }
326     }
327     is($ok, "twenty", $test);
328 }
329
330
331 {
332     my $test = "explicit string comparison (lt)";
333     my $twenty_five = "25";
334     my $ok;
335     given($twenty_five) {
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" }
341     }
342     is($ok, "thirty", $test);
343 }
344
345 {
346     my $test = "explicit string comparison (le)";
347     my $twenty_five = "25";
348     my $ok;
349     given($twenty_five) {
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" }
355     }
356     is($ok, "thirty", $test);
357 }
358
359 {
360     my $test = "explicit string comparison (gt)";
361     my $twenty_five = 25;
362     my $ok;
363     given($twenty_five) {
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" }
369     }
370     is($ok, "twenty", $test);
371 }
372
373 {
374     my $test = "explicit string comparison (ge)";
375     my $twenty_five = 25;
376     my $ok;
377     given($twenty_five) {
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" }
383     }
384     is($ok, "twenty", $test);
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;
392     my $ok;
393     given($twenty_five) {
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" }
399     }
400     is($ok, "twenty", $test);
401 }
402
403 # Optimized-away comparisons
404 {
405     my $ok;
406     given(23) {
407         when (2 + 2 == 4) { $ok = 'y'; continue }
408         when (2 + 2 == 5) { $ok = 'n' }
409     }
410     is($ok, 'y', "Optimized-away comparison");
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
431 sub 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;
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;
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 {
513     my $ok = 0;
514     given("foo") {
515         when((1 == $ok) || "foo") {
516             $ok = 1;
517         }
518     }
519     ok($ok, '((1 == $ok) || "foo") smartmatched');
520 }
521
522 TODO: {
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 }
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
610 my $f = tie my $v, "FetchCounter";
611
612 {   my $test_name = "Only one FETCH (in given)";
613     my $ok;
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     }
622     is($ok, 1, "precheck: $test_name");
623     is($f->count(), 1, $test_name);
624 }
625
626 {   my $test_name = "Only one FETCH (numeric when)";
627     my $ok;
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     }
638     is($ok, 1, "precheck: $test_name");
639     is($f->count(), 1, $test_name);
640 }
641
642 {   my $test_name = "Only one FETCH (string when)";
643     my $ok;
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     }
654     is($ok, 1, "precheck: $test_name");
655     is($f->count(), 1, $test_name);
656 }
657
658 {   my $test_name = "Only one FETCH (undef)";
659     my $ok;
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     }
669     is($ok, 1, "precheck: $test_name");
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) {
754             is($first, 1, "Lexical loop: first");
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
780 sub 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
805 # Test overloading
806 { package OverloadTest;
807
808     use overload '""' => sub{"string value of obj"};
809
810     use overload "~~" => sub {
811         my ($self, $other, $reversed) = @_;
812         if ($reversed) {
813             $self->{left}  = $other;
814             $self->{right} = $self;
815             $self->{reversed} = 1;
816         } else {
817             $self->{left}  = $self;
818             $self->{right} = $other;
819             $self->{reversed} = 0;
820         }
821         $self->{called} = 1;
822         return $self->{retval};
823     };
824     
825     sub new {
826         my ($pkg, $retval) = @_;
827         bless {
828             called => 0,
829             retval => $retval,
830         }, $pkg;
831     }
832 }
833
834 {
835     my $test = "Overloaded obj in given (true)";
836     my $obj = OverloadTest->new(1);
837     my $matched;
838     given($obj) {
839         when ("other arg") {$matched = 1}
840         default {$matched = 0}
841     }
842     
843     is($obj->{called},  1, "$test: called");
844     ok($matched, "$test: matched");
845     is($obj->{left}, "string value of obj", "$test: left");
846     is($obj->{right}, "other arg", "$test: right");
847     ok(!$obj->{reversed}, "$test: not reversed");
848 }
849
850 {
851     my $test = "Overloaded obj in given (false)";
852     my $obj = OverloadTest->new(0);
853     my $matched;
854     given($obj) {
855         when ("other arg") {$matched = 1}
856     }
857     
858     is($obj->{called},  1, "$test: called");
859     ok(!$matched, "$test: not matched");
860     is($obj->{left}, "string value of obj", "$test: left");
861     is($obj->{right}, "other arg", "$test: right");
862     ok(!$obj->{reversed}, "$test: not reversed");
863 }
864
865 {
866     my $test = "Overloaded obj in when (true)";
867     my $obj = OverloadTest->new(1);
868     my $matched;
869     given("topic") {
870         when ($obj) {$matched = 1}
871         default {$matched = 0}
872     }
873     
874     is($obj->{called},  1, "$test: called");
875     ok($matched, "$test: matched");
876     is($obj->{left}, "topic", "$test: left");
877     is($obj->{right}, "string value of obj", "$test: right");
878     ok($obj->{reversed}, "$test: reversed");
879 }
880
881 {
882     my $test = "Overloaded obj in when (false)";
883     my $obj = OverloadTest->new(0);
884     my $matched;
885     given("topic") {
886         when ($obj) {$matched = 1}
887         default {$matched = 0}
888     }
889     
890     is($obj->{called}, 1, "$test: called");
891     ok(!$matched, "$test: not matched");
892     is($obj->{left}, "topic", "$test: left");
893     is($obj->{right}, "string value of obj", "$test: right");
894     ok($obj->{reversed}, "$test: reversed");
895 }
896
897 # Okay, that'll do for now. The intricacies of the smartmatch
898 # semantics are tested in t/op/smartmatch.t
899 __END__