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 => 122;
  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     no warnings "uninitialized";
 137     my $ok = 0;
 138     given (undef) { when(0) {$ok = 1} }
 139     is($ok, 1, "Given(undef) when(0)");
 140 }
 141 {
 142     no warnings "uninitialized";
 143     my $undef;
 144     my $ok = 0;
 145     given ($undef) { when(0) {$ok = 1} }
 146     is($ok, 1, 'Given($undef) when(0)');
 147 }
 148 ########
 149 {
 150     my $ok = 1;
 151     given ("") { when(undef) {$ok = 0} }
 152     is($ok, 1, 'Given("") when(undef)');
 153 }
 154 {
 155     my $undef;
 156     my $ok = 1;
 157     given ("") { when($undef) {$ok = 0} }
 158     is($ok, 1, 'Given("") when($undef)');
 159 }
 160 {
 161     no warnings "uninitialized";
 162     my $ok = 0;
 163     given (undef) { when("") {$ok = 1} }
 164     is($ok, 1, 'Given(undef) when("")');
 165 }
 166 {
 167     no warnings "uninitialized";
 168     my $undef;
 169     my $ok = 0;
 170     given ($undef) { when("") {$ok = 1} }
 171     is($ok, 1, 'Given($undef) when("")');
 172 }
 173 ########
 174 {
 175     my $ok = 0;
 176     given (undef) { when(undef) {$ok = 1} }
 177     is($ok, 1, "Given(undef) when(undef)");
 178 }
 179 {
 180     my $undef;
 181     my $ok = 0;
 182     given (undef) { when($undef) {$ok = 1} }
 183     is($ok, 1, 'Given(undef) when($undef)');
 184 }
 185 {
 186     my $undef;
 187     my $ok = 0;
 188     given ($undef) { when(undef) {$ok = 1} }
 189     is($ok, 1, 'Given($undef) when(undef)');
 190 }
 191 {
 192     my $undef;
 193     my $ok = 0;
 194     given ($undef) { when($undef) {$ok = 1} }
 195     is($ok, 1, 'Given($undef) when($undef)');
 196 }
 197
 198
 199 # Regular expressions
 200 {
 201     my ($ok1, $ok2);
 202     given("Hello, world!") {
 203         when(/lo/)
 204             { $ok1 = 'y'; continue}
 205         when(/no/)
 206             { $ok1 = 'n'; continue}
 207         when(/^(Hello,|Goodbye cruel) world[!.?]/)
 208             { $ok2 = 'Y'; continue}
 209         when(/^(Hello cruel|Goodbye,) world[!.?]/)
 210             { $ok2 = 'n'; continue}
 211     }
 212     is($ok1, 'y', "regex 1");
 213     is($ok2, 'Y', "regex 2");
 214 }
 215
 216 # Comparisons
 217 {
 218     my $test = "explicit numeric comparison (<)";
 219     my $twenty_five = 25;
 220     my $ok;
 221     given($twenty_five) {
 222         when ($_ < 10) { $ok = "ten" }
 223         when ($_ < 20) { $ok = "twenty" }
 224         when ($_ < 30) { $ok = "thirty" }
 225         when ($_ < 40) { $ok = "forty" }
 226         default        { $ok = "default" }
 227     }
 228     is($ok, "thirty", $test);
 229 }
 230
 231 {
 232     use integer;
 233     my $test = "explicit numeric comparison (integer <)";
 234     my $twenty_five = 25;
 235     my $ok;
 236     given($twenty_five) {
 237         when ($_ < 10) { $ok = "ten" }
 238         when ($_ < 20) { $ok = "twenty" }
 239         when ($_ < 30) { $ok = "thirty" }
 240         when ($_ < 40) { $ok = "forty" }
 241         default        { $ok = "default" }
 242     }
 243     is($ok, "thirty", $test);
 244 }
 245
 246 {
 247     my $test = "explicit numeric comparison (<=)";
 248     my $twenty_five = 25;
 249     my $ok;
 250     given($twenty_five) {
 251         when ($_ <= 10) { $ok = "ten" }
 252         when ($_ <= 20) { $ok = "twenty" }
 253         when ($_ <= 30) { $ok = "thirty" }
 254         when ($_ <= 40) { $ok = "forty" }
 255         default         { $ok = "default" }
 256     }
 257     is($ok, "thirty", $test);
 258 }
 259
 260 {
 261     use integer;
 262     my $test = "explicit numeric comparison (integer <=)";
 263     my $twenty_five = 25;
 264     my $ok;
 265     given($twenty_five) {
 266         when ($_ <= 10) { $ok = "ten" }
 267         when ($_ <= 20) { $ok = "twenty" }
 268         when ($_ <= 30) { $ok = "thirty" }
 269         when ($_ <= 40) { $ok = "forty" }
 270         default         { $ok = "default" }
 271     }
 272     is($ok, "thirty", $test);
 273 }
 274
 275
 276 {
 277     my $test = "explicit numeric comparison (>)";
 278     my $twenty_five = 25;
 279     my $ok;
 280     given($twenty_five) {
 281         when ($_ > 40) { $ok = "forty" }
 282         when ($_ > 30) { $ok = "thirty" }
 283         when ($_ > 20) { $ok = "twenty" }
 284         when ($_ > 10) { $ok = "ten" }
 285         default        { $ok = "default" }
 286     }
 287     is($ok, "twenty", $test);
 288 }
 289
 290 {
 291     my $test = "explicit numeric comparison (>=)";
 292     my $twenty_five = 25;
 293     my $ok;
 294     given($twenty_five) {
 295         when ($_ >= 40) { $ok = "forty" }
 296         when ($_ >= 30) { $ok = "thirty" }
 297         when ($_ >= 20) { $ok = "twenty" }
 298         when ($_ >= 10) { $ok = "ten" }
 299         default         { $ok = "default" }
 300     }
 301     is($ok, "twenty", $test);
 302 }
 303
 304 {
 305     use integer;
 306     my $test = "explicit numeric comparison (integer >)";
 307     my $twenty_five = 25;
 308     my $ok;
 309     given($twenty_five) {
 310         when ($_ > 40) { $ok = "forty" }
 311         when ($_ > 30) { $ok = "thirty" }
 312         when ($_ > 20) { $ok = "twenty" }
 313         when ($_ > 10) { $ok = "ten" }
 314         default        { $ok = "default" }
 315     }
 316     is($ok, "twenty", $test);
 317 }
 318
 319 {
 320     use integer;
 321     my $test = "explicit numeric comparison (integer >=)";
 322     my $twenty_five = 25;
 323     my $ok;
 324     given($twenty_five) {
 325         when ($_ >= 40) { $ok = "forty" }
 326         when ($_ >= 30) { $ok = "thirty" }
 327         when ($_ >= 20) { $ok = "twenty" }
 328         when ($_ >= 10) { $ok = "ten" }
 329         default         { $ok = "default" }
 330     }
 331     is($ok, "twenty", $test);
 332 }
 333
 334
 335 {
 336     my $test = "explicit string comparison (lt)";
 337     my $twenty_five = "25";
 338     my $ok;
 339     given($twenty_five) {
 340         when ($_ lt "10") { $ok = "ten" }
 341         when ($_ lt "20") { $ok = "twenty" }
 342         when ($_ lt "30") { $ok = "thirty" }
 343         when ($_ lt "40") { $ok = "forty" }
 344         default           { $ok = "default" }
 345     }
 346     is($ok, "thirty", $test);
 347 }
 348
 349 {
 350     my $test = "explicit string comparison (le)";
 351     my $twenty_five = "25";
 352     my $ok;
 353     given($twenty_five) {
 354         when ($_ le "10") { $ok = "ten" }
 355         when ($_ le "20") { $ok = "twenty" }
 356         when ($_ le "30") { $ok = "thirty" }
 357         when ($_ le "40") { $ok = "forty" }
 358         default           { $ok = "default" }
 359     }
 360     is($ok, "thirty", $test);
 361 }
 362
 363 {
 364     my $test = "explicit string comparison (gt)";
 365     my $twenty_five = 25;
 366     my $ok;
 367     given($twenty_five) {
 368         when ($_ ge "40") { $ok = "forty" }
 369         when ($_ ge "30") { $ok = "thirty" }
 370         when ($_ ge "20") { $ok = "twenty" }
 371         when ($_ ge "10") { $ok = "ten" }
 372         default           { $ok = "default" }
 373     }
 374     is($ok, "twenty", $test);
 375 }
 376
 377 {
 378     my $test = "explicit string comparison (ge)";
 379     my $twenty_five = 25;
 380     my $ok;
 381     given($twenty_five) {
 382         when ($_ ge "40") { $ok = "forty" }
 383         when ($_ ge "30") { $ok = "thirty" }
 384         when ($_ ge "20") { $ok = "twenty" }
 385         when ($_ ge "10") { $ok = "ten" }
 386         default           { $ok = "default" }
 387     }
 388     is($ok, "twenty", $test);
 389 }
 390
 391 # Make sure it still works with a lexical $_:
 392 {
 393     my $_;
 394     my $test = "explicit comparison with lexical \$_";
 395     my $twenty_five = 25;
 396     my $ok;
 397     given($twenty_five) {
 398         when ($_ ge "40") { $ok = "forty" }
 399         when ($_ ge "30") { $ok = "thirty" }
 400         when ($_ ge "20") { $ok = "twenty" }
 401         when ($_ ge "10") { $ok = "ten" }
 402         default           { $ok = "default" }
 403     }
 404     is($ok, "twenty", $test);
 405 }
 406
 407 # Optimized-away comparisons
 408 {
 409     my $ok;
 410     given(23) {
 411         when (2 + 2 == 4) { $ok = 'y'; continue }
 412         when (2 + 2 == 5) { $ok = 'n' }
 413     }
 414     is($ok, 'y', "Optimized-away comparison");
 415 }
 416
 417 # File tests
 418 #  (How to be both thorough and portable? Pinch a few ideas
 419 #  from t/op/filetest.t. We err on the side of portability for
 420 #  the time being.)
 421
 422 {
 423     my ($ok_d, $ok_f, $ok_r);
 424     given("op") {
 425         when(-d)  {$ok_d = 1; continue}
 426         when(!-f) {$ok_f = 1; continue}
 427         when(-r)  {$ok_r = 1; continue}
 428     }
 429     ok($ok_d, "Filetest -d");
 430     ok($ok_f, "Filetest -f");
 431     ok($ok_r, "Filetest -r");
 432 }
 433
 434 # Sub and method calls
 435 sub notfoo {"bar"}
 436 {
 437     my $ok = 0;
 438     given("foo") {
 439         when(notfoo()) {$ok = 1}
 440     }
 441     ok($ok, "Sub call acts as boolean")
 442 }
 443
 444 {
 445     my $ok = 0;
 446     given("foo") {
 447         when(main->notfoo()) {$ok = 1}
 448     }
 449     ok($ok, "Class-method call acts as boolean")
 450 }
 451
 452 {
 453     my $ok = 0;
 454     my $obj = bless [];
 455     given("foo") {
 456         when($obj->notfoo()) {$ok = 1}
 457     }
 458     ok($ok, "Object-method call acts as boolean")
 459 }
 460
 461 # Other things that should not be smart matched
 462 {
 463     my $ok = 0;
 464     given(12) {
 465         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
 466             $ok = 1;
 467         }
 468     }
 469     ok($ok, "bool not smartmatches");
 470 }
 471
 472 {
 473     my $ok = 0;
 474     given(0) {
 475         when(eof(DATA)) {
 476             $ok = 1;
 477         }
 478     }
 479     ok($ok, "eof() not smartmatched");
 480 }
 481
 482 {
 483     my $ok = 0;
 484     my %foo = ("bar", 0);
 485     given(0) {
 486         when(exists $foo{bar}) {
 487             $ok = 1;
 488         }
 489     }
 490     ok($ok, "exists() not smartmatched");
 491 }
 492
 493 {
 494     my $ok = 0;
 495     given(0) {
 496         when(defined $ok) {
 497             $ok = 1;
 498         }
 499     }
 500     ok($ok, "defined() not smartmatched");
 501 }
 502
 503 {
 504     my $ok = 1;
 505     given("foo") {
 506         when((1 == 1) && "bar") {
 507             $ok = 0;
 508         }
 509         when((1 == 1) && $_ eq "foo") {
 510             $ok = 2;
 511         }
 512     }
 513     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
 514 }
 515
 516 {
 517     my $n = 0;
 518     for my $l qw(a b c d) {
 519         given ($l) {
 520             when ($_ eq "b" .. $_ eq "c") { $n = 1 }
 521             default { $n = 0 }
 522         }
 523         ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
 524     }
 525 }
 526
 527 {
 528     my $n = 0;
 529     for my $l qw(a b c d) {
 530         given ($l) {
 531             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
 532             default { $n = 0 }
 533         }
 534         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
 535     }
 536 }
 537
 538 {
 539     my $ok = 0;
 540     given("foo") {
 541         when((1 == $ok) || "foo") {
 542             $ok = 1;
 543         }
 544     }
 545     ok($ok, '((1 == $ok) || "foo") smartmatched');
 546 }
 547
 548 {
 549     my $ok = 0;
 550     given("foo") {
 551         when((1 == $ok || undef) // "foo") {
 552             $ok = 1;
 553         }
 554     }
 555     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 556 }
 557
 558 # Make sure we aren't invoking the get-magic more than once
 559
 560 { # A helper class to count the number of accesses.
 561     package FetchCounter;
 562     sub TIESCALAR {
 563         my ($class) = @_;
 564         bless {value => undef, count => 0}, $class;
 565     }
 566     sub STORE {
 567         my ($self, $val) = @_;
 568         $self->{count} = 0;
 569         $self->{value} = $val;
 570     }
 571     sub FETCH {
 572         my ($self) = @_;
 573         # Avoid pre/post increment here
 574         $self->{count} = 1 + $self->{count};
 575         $self->{value};
 576     }
 577     sub count {
 578         my ($self) = @_;
 579         $self->{count};
 580     }
 581 }
 582
 583 my $f = tie my $v, "FetchCounter";
 584
 585 {   my $test_name = "Only one FETCH (in given)";
 586     my $ok;
 587     given($v = 23) {
 588         when(undef) {}
 589         when(sub{0}->()) {}
 590         when(21) {}
 591         when("22") {}
 592         when(23) {$ok = 1}
 593         when(/24/) {$ok = 0}
 594     }
 595     is($ok, 1, "precheck: $test_name");
 596     is($f->count(), 1, $test_name);
 597 }
 598
 599 {   my $test_name = "Only one FETCH (numeric when)";
 600     my $ok;
 601     $v = 23;
 602     is($f->count(), 0, "Sanity check: $test_name");
 603     given(23) {
 604         when(undef) {}
 605         when(sub{0}->()) {}
 606         when(21) {}
 607         when("22") {}
 608         when($v) {$ok = 1}
 609         when(/24/) {$ok = 0}
 610     }
 611     is($ok, 1, "precheck: $test_name");
 612     is($f->count(), 1, $test_name);
 613 }
 614
 615 {   my $test_name = "Only one FETCH (string when)";
 616     my $ok;
 617     $v = "23";
 618     is($f->count(), 0, "Sanity check: $test_name");
 619     given("23") {
 620         when(undef) {}
 621         when(sub{0}->()) {}
 622         when("21") {}
 623         when("22") {}
 624         when($v) {$ok = 1}
 625         when(/24/) {$ok = 0}
 626     }
 627     is($ok, 1, "precheck: $test_name");
 628     is($f->count(), 1, $test_name);
 629 }
 630
 631 {   my $test_name = "Only one FETCH (undef)";
 632     my $ok;
 633     $v = undef;
 634     is($f->count(), 0, "Sanity check: $test_name");
 635     no warnings "uninitialized";
 636     given(my $undef) {
 637         when(sub{0}->()) {}
 638         when("21")  {}
 639         when("22")  {}
 640         when($v)    {$ok = 1}
 641         when(undef) {$ok = 0}
 642     }
 643     is($ok, 1, "precheck: $test_name");
 644     is($f->count(), 1, $test_name);
 645 }
 646
 647 # Loop topicalizer
 648 {
 649     my $first = 1;
 650     for (1, "two") {
 651         when ("two") {
 652             is($first, 0, "Loop: second");
 653             eval {break};
 654             like($@, qr/^Can't "break" in a loop topicalizer/,
 655                 q{Can't "break" in a loop topicalizer});
 656         }
 657         when (1) {
 658             is($first, 1, "Loop: first");
 659             $first = 0;
 660             # Implicit break is okay
 661         }
 662     }
 663 }
 664
 665 {
 666     my $first = 1;
 667     for $_ (1, "two") {
 668         when ("two") {
 669             is($first, 0, "Explicit \$_: second");
 670             eval {break};
 671             like($@, qr/^Can't "break" in a loop topicalizer/,
 672                 q{Can't "break" in a loop topicalizer});
 673         }
 674         when (1) {
 675             is($first, 1, "Explicit \$_: first");
 676             $first = 0;
 677             # Implicit break is okay
 678         }
 679     }
 680 }
 681
 682 {
 683     my $first = 1;
 684     my $_;
 685     for (1, "two") {
 686         when ("two") {
 687             is($first, 0, "Implicitly lexical loop: second");
 688             eval {break};
 689             like($@, qr/^Can't "break" in a loop topicalizer/,
 690                 q{Can't "break" in a loop topicalizer});
 691         }
 692         when (1) {
 693             is($first, 1, "Implicitly lexical loop: first");
 694             $first = 0;
 695             # Implicit break is okay
 696         }
 697     }
 698 }
 699
 700 {
 701     my $first = 1;
 702     my $_;
 703     for $_ (1, "two") {
 704         when ("two") {
 705             is($first, 0, "Implicitly lexical, explicit \$_: second");
 706             eval {break};
 707             like($@, qr/^Can't "break" in a loop topicalizer/,
 708                 q{Can't "break" in a loop topicalizer});
 709         }
 710         when (1) {
 711             is($first, 1, "Implicitly lexical, explicit \$_: first");
 712             $first = 0;
 713             # Implicit break is okay
 714         }
 715     }
 716 }
 717
 718 {
 719     my $first = 1;
 720     for my $_ (1, "two") {
 721         when ("two") {
 722             is($first, 0, "Lexical loop: second");
 723             eval {break};
 724             like($@, qr/^Can't "break" in a loop topicalizer/,
 725                 q{Can't "break" in a loop topicalizer});
 726         }
 727         when (1) {
 728             is($first, 1, "Lexical loop: first");
 729             $first = 0;
 730             # Implicit break is okay
 731         }
 732     }
 733 }
 734
 735
 736 # Code references
 737 {
 738     no warnings "redefine";
 739     my $called_foo = 0;
 740     sub foo {$called_foo = 1; "@_" eq "foo"}
 741     my $called_bar = 0;
 742     sub bar {$called_bar = 1; "@_" eq "bar"}
 743     my ($matched_foo, $matched_bar) = (0, 0);
 744     given("foo") {
 745         when(\&bar) {$matched_bar = 1}
 746         when(\&foo) {$matched_foo = 1}
 747     }
 748     is($called_foo, 1,  "foo() was called");
 749     is($called_bar, 1,  "bar() was called");
 750     is($matched_bar, 0, "bar didn't match");
 751     is($matched_foo, 1, "foo did match");
 752 }
 753
 754 sub contains_x {
 755     my $x = shift;
 756     return ($x =~ /x/);
 757 }
 758 {
 759     my ($ok1, $ok2) = (0,0);
 760     given("foxy!") {
 761         when(contains_x($_))
 762             { $ok1 = 1; continue }
 763         when(\&contains_x)
 764             { $ok2 = 1; continue }
 765     }
 766     is($ok1, 1, "Calling sub directly (true)");
 767     is($ok2, 1, "Calling sub indirectly (true)");
 768
 769     given("foggy") {
 770         when(contains_x($_))
 771             { $ok1 = 2; continue }
 772         when(\&contains_x)
 773             { $ok2 = 2; continue }
 774     }
 775     is($ok1, 1, "Calling sub directly (false)");
 776     is($ok2, 1, "Calling sub indirectly (false)");
 777 }
 778
 779 SKIP: {
 780     skip "Scalar/Util.pm not yet available", 20
 781         unless -r "$INC[0]/Scalar/Util.pm";
 782     # Test overloading
 783     { package OverloadTest;
 784
 785       use overload '""' => sub{"string value of obj"};
 786       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 787
 788       use overload "~~" => sub {
 789           my ($self, $other, $reversed) = @_;
 790           if ($reversed) {
 791               $self->{left}  = $other;
 792               $self->{right} = $self;
 793               $self->{reversed} = 1;
 794           } else {
 795               $self->{left}  = $self;
 796               $self->{right} = $other;
 797               $self->{reversed} = 0;
 798           }
 799           $self->{called} = 1;
 800           return $self->{retval};
 801       };
 802
 803       sub new {
 804           my ($pkg, $retval) = @_;
 805           bless {
 806                  called => 0,
 807                  retval => $retval,
 808                 }, $pkg;
 809       }
 810   }
 811
 812     {
 813         my $test = "Overloaded obj in given (true)";
 814         my $obj = OverloadTest->new(1);
 815         my $matched;
 816         given($obj) {
 817             when ("other arg") {$matched = 1}
 818             default {$matched = 0}
 819         }
 820
 821         is($obj->{called}, 0, "$test: called");
 822         ok(!$matched, "$test: not matched");
 823     }
 824
 825     {
 826         my $test = "Overloaded obj in given (false)";
 827         my $obj = OverloadTest->new(0);
 828         my $matched;
 829         given($obj) {
 830             when ("other arg") {$matched = 1}
 831         }
 832
 833         is($obj->{called}, 0, "$test: called");
 834         ok(!$matched, "$test: not matched");
 835     }
 836
 837     {
 838         my $test = "Overloaded obj in when (true)";
 839         my $obj = OverloadTest->new(1);
 840         my $matched;
 841         given("topic") {
 842             when ($obj) {$matched = 1}
 843             default {$matched = 0}
 844         }
 845
 846         is($obj->{called},  1, "$test: called");
 847         ok($matched, "$test: matched");
 848         is($obj->{left}, "topic", "$test: left");
 849         is($obj->{right}, "string value of obj", "$test: right");
 850         ok($obj->{reversed}, "$test: reversed");
 851     }
 852
 853     {
 854         my $test = "Overloaded obj in when (false)";
 855         my $obj = OverloadTest->new(0);
 856         my $matched;
 857         given("topic") {
 858             when ($obj) {$matched = 1}
 859             default {$matched = 0}
 860         }
 861
 862         is($obj->{called}, 1, "$test: called");
 863         ok(!$matched, "$test: not matched");
 864         is($obj->{left}, "topic", "$test: left");
 865         is($obj->{right}, "string value of obj", "$test: right");
 866         ok($obj->{reversed}, "$test: reversed");
 867     }
 868 }
 869
 870 # Postfix when
 871 {
 872     my $ok;
 873     given (undef) {
 874         $ok = 1 when undef;
 875     }
 876     is($ok, 1, "postfix undef");
 877 }
 878 {
 879     my $ok;
 880     given (2) {
 881         $ok += 1 when 7;
 882         $ok += 2 when 9.1685;
 883         $ok += 4 when $_ > 4;
 884         $ok += 8 when $_ < 2.5;
 885     }
 886     is($ok, 8, "postfix numeric");
 887 }
 888 {
 889     my $ok;
 890     given ("apple") {
 891         $ok = 1, continue when $_ eq "apple";
 892         $ok += 2;
 893         $ok = 0 when "banana";
 894     }
 895     is($ok, 3, "postfix string");
 896 }
 897 {
 898     my $ok;
 899     given ("pear") {
 900         do { $ok = 1; continue } when /pea/;
 901         $ok += 2;
 902         $ok = 0 when /pie/;
 903         default { $ok += 4 }
 904         $ok = 0;
 905     }
 906     is($ok, 7, "postfix regex");
 907 }
 908 # be_true is defined at the beginning of the file
 909 {
 910     my $x = "what";
 911     given(my $x = "foo") {
 912         do {
 913             is($x, "foo", "scope inside ... when my \$x = ...");
 914             continue;
 915         } when be_true(my $x = "bar");
 916         is($x, "bar", "scope after ... when my \$x = ...");
 917     }
 918 }
 919 {
 920     my $x = 0;
 921     given(my $x = 1) {
 922         my $x = 2, continue when be_true();
 923         is($x, undef, "scope after my \$x = ... when ...");
 924     }
 925 }
 926
 927 # Tests for last and next in when clauses
 928 my $letter;
 929
 930 $letter = '';
 931 for ("a".."e") {
 932     given ($_) {
 933         $letter = $_;
 934         when ("b") { last }
 935     }
 936     $letter = "z";
 937 }
 938 is($letter, "b", "last in when");
 939
 940 $letter = '';
 941 LETTER1: for ("a".."e") {
 942     given ($_) {
 943         $letter = $_;
 944         when ("b") { last LETTER1 }
 945     }
 946     $letter = "z";
 947 }
 948 is($letter, "b", "last LABEL in when");
 949
 950 $letter = '';
 951 for ("a".."e") {
 952     given ($_) {
 953         when (/b|d/) { next }
 954         $letter .= $_;
 955     }
 956     $letter .= ',';
 957 }
 958 is($letter, "a,c,e,", "next in when");
 959
 960 $letter = '';
 961 LETTER2: for ("a".."e") {
 962     given ($_) {
 963         when (/b|d/) { next LETTER2 }
 964         $letter .= $_;
 965     }
 966     $letter .= ',';
 967 }
 968 is($letter, "a,c,e,", "next LABEL in when");
 969
 970 # Okay, that'll do for now. The intricacies of the smartmatch
 971 # semantics are tested in t/op/smartmatch.t
 972 __END__