t/op/switch.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8
   9 use strict;
  10 use warnings;
  11
  12 plan tests => 128;
  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.
  17
  18 use feature 'switch';
  19
  20 eval { continue };
  21 like($@, qr/^Can't "continue" outside/, "continue outside");
  22
  23 eval { break };
  24 like($@, 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
  36 sub be_true {1}
  37
  38 given(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";
  46 given("inside") { check_outside1() }
  47 sub 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 {
  60     my $ok;
  61     given(3) {
  62         when(2) { $ok = 'two'; }
  63         when(3) { $ok = 'three'; }
  64         when(4) { $ok = 'four'; }
  65         default { $ok = 'd'; }
  66     }
  67     is($ok, 'three', "numeric comparison");
  68 }
  69
  70 {
  71     my $ok;
  72     use integer;
  73     given(3.14159265) {
  74         when(2) { $ok = 'two'; }
  75         when(3) { $ok = 'three'; }
  76         when(4) { $ok = 'four'; }
  77         default { $ok = 'd'; }
  78     }
  79     is($ok, 'three', "integer comparison");
  80 }
  81
  82 {
  83     my ($ok1, $ok2);
  84     given(3) {
  85         when(3.1)   { $ok1 = 'n'; }
  86         when(3.0)   { $ok1 = 'y'; continue }
  87         when("3.0") { $ok2 = 'y'; }
  88         default     { $ok2 = 'n'; }
  89     }
  90     is($ok1, 'y', "more numeric (pt. 1)");
  91     is($ok2, 'y', "more numeric (pt. 2)");
  92 }
  93
  94 {
  95     my $ok;
  96     given("c") {
  97         when("b") { $ok = 'B'; }
  98         when("c") { $ok = 'C'; }
  99         when("d") { $ok = 'D'; }
 100         default   { $ok = 'def'; }
 101     }
 102     is($ok, 'C', "string comparison");
 103 }
 104
 105 {
 106     my $ok;
 107     given("c") {
 108         when("b") { $ok = 'B'; }
 109         when("c") { $ok = 'C'; continue }
 110         when("c") { $ok = 'CC'; }
 111         default   { $ok = 'D'; }
 112     }
 113     is($ok, 'CC', "simple continue");
 114 }
 115
 116 # Definedness
 117 {
 118     my $ok = 1;
 119     given (0) { when(undef) {$ok = 0} }
 120     is($ok, 1, "Given(0) when(undef)");
 121 }
 122 {
 123     my $undef;
 124     my $ok = 1;
 125     given (0) { when($undef) {$ok = 0} }
 126     is($ok, 1, 'Given(0) when($undef)');
 127 }
 128 {
 129     my $undef;
 130     my $ok = 0;
 131     given (0) { when($undef++) {$ok = 1} }
 132     is($ok, 1, "Given(0) when($undef++)");
 133 }
 134 {
 135     no warnings "uninitialized";
 136     my $ok = 1;
 137     given (undef) { when(0) {$ok = 0} }
 138     is($ok, 1, "Given(undef) when(0)");
 139 }
 140 {
 141     no warnings "uninitialized";
 142     my $undef;
 143     my $ok = 1;
 144     given ($undef) { when(0) {$ok = 0} }
 145     is($ok, 1, 'Given($undef) when(0)');
 146 }
 147 ########
 148 {
 149     my $ok = 1;
 150     given ("") { when(undef) {$ok = 0} }
 151     is($ok, 1, 'Given("") when(undef)');
 152 }
 153 {
 154     my $undef;
 155     my $ok = 1;
 156     given ("") { when($undef) {$ok = 0} }
 157     is($ok, 1, 'Given("") when($undef)');
 158 }
 159 {
 160     no warnings "uninitialized";
 161     my $ok = 1;
 162     given (undef) { when("") {$ok = 0} }
 163     is($ok, 1, 'Given(undef) when("")');
 164 }
 165 {
 166     no warnings "uninitialized";
 167     my $undef;
 168     my $ok = 1;
 169     given ($undef) { when("") {$ok = 0} }
 170     is($ok, 1, 'Given($undef) when("")');
 171 }
 172 ########
 173 {
 174     my $ok = 0;
 175     given (undef) { when(undef) {$ok = 1} }
 176     is($ok, 1, "Given(undef) when(undef)");
 177 }
 178 {
 179     my $undef;
 180     my $ok = 0;
 181     given (undef) { when($undef) {$ok = 1} }
 182     is($ok, 1, 'Given(undef) when($undef)');
 183 }
 184 {
 185     my $undef;
 186     my $ok = 0;
 187     given ($undef) { when(undef) {$ok = 1} }
 188     is($ok, 1, 'Given($undef) when(undef)');
 189 }
 190 {
 191     my $undef;
 192     my $ok = 0;
 193     given ($undef) { when($undef) {$ok = 1} }
 194     is($ok, 1, 'Given($undef) when($undef)');
 195 }
 196
 197
 198 # Regular expressions
 199 {
 200     my ($ok1, $ok2);
 201     given("Hello, world!") {
 202         when(/lo/)
 203             { $ok1 = 'y'; continue}
 204         when(/no/)
 205             { $ok1 = 'n'; continue}
 206         when(/^(Hello,|Goodbye cruel) world[!.?]/)
 207             { $ok2 = 'Y'; continue}
 208         when(/^(Hello cruel|Goodbye,) world[!.?]/)
 209             { $ok2 = 'n'; continue}
 210     }
 211     is($ok1, 'y', "regex 1");
 212     is($ok2, 'Y', "regex 2");
 213 }
 214
 215 # Comparisons
 216 {
 217     my $test = "explicit numeric comparison (<)";
 218     my $twenty_five = 25;
 219     my $ok;
 220     given($twenty_five) {
 221         when ($_ < 10) { $ok = "ten" }
 222         when ($_ < 20) { $ok = "twenty" }
 223         when ($_ < 30) { $ok = "thirty" }
 224         when ($_ < 40) { $ok = "forty" }
 225         default        { $ok = "default" }
 226     }
 227     is($ok, "thirty", $test);
 228 }
 229
 230 {
 231     use integer;
 232     my $test = "explicit numeric comparison (integer <)";
 233     my $twenty_five = 25;
 234     my $ok;
 235     given($twenty_five) {
 236         when ($_ < 10) { $ok = "ten" }
 237         when ($_ < 20) { $ok = "twenty" }
 238         when ($_ < 30) { $ok = "thirty" }
 239         when ($_ < 40) { $ok = "forty" }
 240         default        { $ok = "default" }
 241     }
 242     is($ok, "thirty", $test);
 243 }
 244
 245 {
 246     my $test = "explicit numeric comparison (<=)";
 247     my $twenty_five = 25;
 248     my $ok;
 249     given($twenty_five) {
 250         when ($_ <= 10) { $ok = "ten" }
 251         when ($_ <= 20) { $ok = "twenty" }
 252         when ($_ <= 30) { $ok = "thirty" }
 253         when ($_ <= 40) { $ok = "forty" }
 254         default         { $ok = "default" }
 255     }
 256     is($ok, "thirty", $test);
 257 }
 258
 259 {
 260     use integer;
 261     my $test = "explicit numeric comparison (integer <=)";
 262     my $twenty_five = 25;
 263     my $ok;
 264     given($twenty_five) {
 265         when ($_ <= 10) { $ok = "ten" }
 266         when ($_ <= 20) { $ok = "twenty" }
 267         when ($_ <= 30) { $ok = "thirty" }
 268         when ($_ <= 40) { $ok = "forty" }
 269         default         { $ok = "default" }
 270     }
 271     is($ok, "thirty", $test);
 272 }
 273
 274
 275 {
 276     my $test = "explicit numeric comparison (>)";
 277     my $twenty_five = 25;
 278     my $ok;
 279     given($twenty_five) {
 280         when ($_ > 40) { $ok = "forty" }
 281         when ($_ > 30) { $ok = "thirty" }
 282         when ($_ > 20) { $ok = "twenty" }
 283         when ($_ > 10) { $ok = "ten" }
 284         default        { $ok = "default" }
 285     }
 286     is($ok, "twenty", $test);
 287 }
 288
 289 {
 290     my $test = "explicit numeric comparison (>=)";
 291     my $twenty_five = 25;
 292     my $ok;
 293     given($twenty_five) {
 294         when ($_ >= 40) { $ok = "forty" }
 295         when ($_ >= 30) { $ok = "thirty" }
 296         when ($_ >= 20) { $ok = "twenty" }
 297         when ($_ >= 10) { $ok = "ten" }
 298         default         { $ok = "default" }
 299     }
 300     is($ok, "twenty", $test);
 301 }
 302
 303 {
 304     use integer;
 305     my $test = "explicit numeric comparison (integer >)";
 306     my $twenty_five = 25;
 307     my $ok;
 308     given($twenty_five) {
 309         when ($_ > 40) { $ok = "forty" }
 310         when ($_ > 30) { $ok = "thirty" }
 311         when ($_ > 20) { $ok = "twenty" }
 312         when ($_ > 10) { $ok = "ten" }
 313         default        { $ok = "default" }
 314     }
 315     is($ok, "twenty", $test);
 316 }
 317
 318 {
 319     use integer;
 320     my $test = "explicit numeric comparison (integer >=)";
 321     my $twenty_five = 25;
 322     my $ok;
 323     given($twenty_five) {
 324         when ($_ >= 40) { $ok = "forty" }
 325         when ($_ >= 30) { $ok = "thirty" }
 326         when ($_ >= 20) { $ok = "twenty" }
 327         when ($_ >= 10) { $ok = "ten" }
 328         default         { $ok = "default" }
 329     }
 330     is($ok, "twenty", $test);
 331 }
 332
 333
 334 {
 335     my $test = "explicit string comparison (lt)";
 336     my $twenty_five = "25";
 337     my $ok;
 338     given($twenty_five) {
 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" }
 344     }
 345     is($ok, "thirty", $test);
 346 }
 347
 348 {
 349     my $test = "explicit string comparison (le)";
 350     my $twenty_five = "25";
 351     my $ok;
 352     given($twenty_five) {
 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" }
 358     }
 359     is($ok, "thirty", $test);
 360 }
 361
 362 {
 363     my $test = "explicit string comparison (gt)";
 364     my $twenty_five = 25;
 365     my $ok;
 366     given($twenty_five) {
 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" }
 372     }
 373     is($ok, "twenty", $test);
 374 }
 375
 376 {
 377     my $test = "explicit string comparison (ge)";
 378     my $twenty_five = 25;
 379     my $ok;
 380     given($twenty_five) {
 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" }
 386     }
 387     is($ok, "twenty", $test);
 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;
 395     my $ok;
 396     given($twenty_five) {
 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" }
 402     }
 403     is($ok, "twenty", $test);
 404 }
 405
 406 # Optimized-away comparisons
 407 {
 408     my $ok;
 409     given(23) {
 410         when (2 + 2 == 4) { $ok = 'y'; continue }
 411         when (2 + 2 == 5) { $ok = 'n' }
 412     }
 413     is($ok, 'y', "Optimized-away comparison");
 414 }
 415
 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
 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
 443 sub notfoo {"bar"}
 444 {
 445     my $ok = 0;
 446     given("foo") {
 447         when(notfoo()) {$ok = 1}
 448     }
 449     ok($ok, "Sub call acts as boolean")
 450 }
 451
 452 {
 453     my $ok = 0;
 454     given("foo") {
 455         when(main->notfoo()) {$ok = 1}
 456     }
 457     ok($ok, "Class-method call acts as boolean")
 458 }
 459
 460 {
 461     my $ok = 0;
 462     my $obj = bless [];
 463     given("foo") {
 464         when($obj->notfoo()) {$ok = 1}
 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;
 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;
 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 {
 525     my $n = 0;
 526     for my $l qw(a b c d) {
 527         given ($l) {
 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) {
 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 {
 547     my $ok = 0;
 548     given("foo") {
 549         when((1 == $ok) || "foo") {
 550             $ok = 1;
 551         }
 552     }
 553     ok($ok, '((1 == $ok) || "foo") smartmatched');
 554 }
 555
 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
 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
 591 my $f = tie my $v, "FetchCounter";
 592
 593 {   my $test_name = "Only one FETCH (in given)";
 594     my $ok;
 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     }
 603     is($ok, 1, "precheck: $test_name");
 604     is($f->count(), 1, $test_name);
 605 }
 606
 607 {   my $test_name = "Only one FETCH (numeric when)";
 608     my $ok;
 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     }
 619     is($ok, 1, "precheck: $test_name");
 620     is($f->count(), 1, $test_name);
 621 }
 622
 623 {   my $test_name = "Only one FETCH (string when)";
 624     my $ok;
 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     }
 635     is($ok, 1, "precheck: $test_name");
 636     is($f->count(), 1, $test_name);
 637 }
 638
 639 {   my $test_name = "Only one FETCH (undef)";
 640     my $ok;
 641     $v = undef;
 642     is($f->count(), 0, "Sanity check: $test_name");
 643     no warnings "uninitialized";
 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     }
 651     is($ok, 1, "precheck: $test_name");
 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) {
 736             is($first, 1, "Lexical loop: first");
 737             $first = 0;
 738             # Implicit break is okay
 739         }
 740     }
 741 }
 742
 743
 744 # Code references
 745 {
 746     my $called_foo = 0;
 747     sub foo {$called_foo = 1; "@_" eq "foo"}
 748     my $called_bar = 0;
 749     sub bar {$called_bar = 1; "@_" eq "bar"}
 750     my ($matched_foo, $matched_bar) = (0, 0);
 751     given("foo") {
 752         when(\&bar) {$matched_bar = 1}
 753         when(\&foo) {$matched_foo = 1}
 754     }
 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");
 759 }
 760
 761 sub 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
 786 SKIP: {
 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"};
 793       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 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       };
 809
 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         }
 827
 828         is($obj->{called}, 1, "$test: called");
 829         ok($matched, "$test: matched");
 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         }
 839
 840         is($obj->{called}, 1, "$test: called");
 841         ok(!$matched, "$test: not matched");
 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         }
 852
 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         }
 868
 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     }
 875 }
 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
 934 # Tests for last and next in when clauses
 935 my $letter;
 936
 937 $letter = '';
 938 for ("a".."e") {
 939     given ($_) {
 940         $letter = $_;
 941         when ("b") { last }
 942     }
 943     $letter = "z";
 944 }
 945 is($letter, "b", "last in when");
 946
 947 $letter = '';
 948 LETTER1: for ("a".."e") {
 949     given ($_) {
 950         $letter = $_;
 951         when ("b") { last LETTER1 }
 952     }
 953     $letter = "z";
 954 }
 955 is($letter, "b", "last LABEL in when");
 956
 957 $letter = '';
 958 for ("a".."e") {
 959     given ($_) {
 960         when (/b|d/) { next }
 961         $letter .= $_;
 962     }
 963     $letter .= ',';
 964 }
 965 is($letter, "a,c,e,", "next in when");
 966
 967 $letter = '';
 968 LETTER2: for ("a".."e") {
 969     given ($_) {
 970         when (/b|d/) { next LETTER2 }
 971         $letter .= $_;
 972     }
 973     $letter .= ',';
 974 }
 975 is($letter, "a,c,e,", "next LABEL in when");
 976
 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     }
 995 GIVEN2:
 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     }
1004 GIVEN3:
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     }
1013 GIVEN4:
1014     is($flag, 1, "goto inside for and when");
1015 }
1016 {
1017     my $flag = 0;
1018 GIVEN5:
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
1027 # Okay, that'll do for now. The intricacies of the smartmatch
1028 # semantics are tested in t/op/smartmatch.t
1029 __END__