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 => 166;
  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_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
 788     # Test overloading
 789     { package OverloadTest;
 790
 791       use overload '""' => sub{"string value of obj"};
 792       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 793
 794       use overload "~~" => sub {
 795           my ($self, $other, $reversed) = @_;
 796           if ($reversed) {
 797               $self->{left}  = $other;
 798               $self->{right} = $self;
 799               $self->{reversed} = 1;
 800           } else {
 801               $self->{left}  = $self;
 802               $self->{right} = $other;
 803               $self->{reversed} = 0;
 804           }
 805           $self->{called} = 1;
 806           return $self->{retval};
 807       };
 808
 809       sub new {
 810           my ($pkg, $retval) = @_;
 811           bless {
 812                  called => 0,
 813                  retval => $retval,
 814                 }, $pkg;
 815       }
 816   }
 817
 818     {
 819         my $test = "Overloaded obj in given (true)";
 820         my $obj = OverloadTest->new(1);
 821         my $matched;
 822         given($obj) {
 823             when ("other arg") {$matched = 1}
 824             default {$matched = 0}
 825         }
 826
 827         is($obj->{called}, 1, "$test: called");
 828         ok($matched, "$test: matched");
 829     }
 830
 831     {
 832         my $test = "Overloaded obj in given (false)";
 833         my $obj = OverloadTest->new(0);
 834         my $matched;
 835         given($obj) {
 836             when ("other arg") {$matched = 1}
 837         }
 838
 839         is($obj->{called}, 1, "$test: called");
 840         ok(!$matched, "$test: not matched");
 841     }
 842
 843     {
 844         my $test = "Overloaded obj in when (true)";
 845         my $obj = OverloadTest->new(1);
 846         my $matched;
 847         given("topic") {
 848             when ($obj) {$matched = 1}
 849             default {$matched = 0}
 850         }
 851
 852         is($obj->{called},  1, "$test: called");
 853         ok($matched, "$test: matched");
 854         is($obj->{left}, "topic", "$test: left");
 855         is($obj->{right}, "string value of obj", "$test: right");
 856         ok($obj->{reversed}, "$test: reversed");
 857     }
 858
 859     {
 860         my $test = "Overloaded obj in when (false)";
 861         my $obj = OverloadTest->new(0);
 862         my $matched;
 863         given("topic") {
 864             when ($obj) {$matched = 1}
 865             default {$matched = 0}
 866         }
 867
 868         is($obj->{called}, 1, "$test: called");
 869         ok(!$matched, "$test: not matched");
 870         is($obj->{left}, "topic", "$test: left");
 871         is($obj->{right}, "string value of obj", "$test: right");
 872         ok($obj->{reversed}, "$test: reversed");
 873     }
 874 }
 875
 876 # Postfix when
 877 {
 878     my $ok;
 879     given (undef) {
 880         $ok = 1 when undef;
 881     }
 882     is($ok, 1, "postfix undef");
 883 }
 884 {
 885     my $ok;
 886     given (2) {
 887         $ok += 1 when 7;
 888         $ok += 2 when 9.1685;
 889         $ok += 4 when $_ > 4;
 890         $ok += 8 when $_ < 2.5;
 891     }
 892     is($ok, 8, "postfix numeric");
 893 }
 894 {
 895     my $ok;
 896     given ("apple") {
 897         $ok = 1, continue when $_ eq "apple";
 898         $ok += 2;
 899         $ok = 0 when "banana";
 900     }
 901     is($ok, 3, "postfix string");
 902 }
 903 {
 904     my $ok;
 905     given ("pear") {
 906         do { $ok = 1; continue } when /pea/;
 907         $ok += 2;
 908         $ok = 0 when /pie/;
 909         default { $ok += 4 }
 910         $ok = 0;
 911     }
 912     is($ok, 7, "postfix regex");
 913 }
 914 # be_true is defined at the beginning of the file
 915 {
 916     my $x = "what";
 917     given(my $x = "foo") {
 918         do {
 919             is($x, "foo", "scope inside ... when my \$x = ...");
 920             continue;
 921         } when be_true(my $x = "bar");
 922         is($x, "bar", "scope after ... when my \$x = ...");
 923     }
 924 }
 925 {
 926     my $x = 0;
 927     given(my $x = 1) {
 928         my $x = 2, continue when be_true();
 929         is($x, undef, "scope after my \$x = ... when ...");
 930     }
 931 }
 932
 933 # Tests for last and next in when clauses
 934 my $letter;
 935
 936 $letter = '';
 937 for ("a".."e") {
 938     given ($_) {
 939         $letter = $_;
 940         when ("b") { last }
 941     }
 942     $letter = "z";
 943 }
 944 is($letter, "b", "last in when");
 945
 946 $letter = '';
 947 LETTER1: for ("a".."e") {
 948     given ($_) {
 949         $letter = $_;
 950         when ("b") { last LETTER1 }
 951     }
 952     $letter = "z";
 953 }
 954 is($letter, "b", "last LABEL in when");
 955
 956 $letter = '';
 957 for ("a".."e") {
 958     given ($_) {
 959         when (/b|d/) { next }
 960         $letter .= $_;
 961     }
 962     $letter .= ',';
 963 }
 964 is($letter, "a,c,e,", "next in when");
 965
 966 $letter = '';
 967 LETTER2: for ("a".."e") {
 968     given ($_) {
 969         when (/b|d/) { next LETTER2 }
 970         $letter .= $_;
 971     }
 972     $letter .= ',';
 973 }
 974 is($letter, "a,c,e,", "next LABEL in when");
 975
 976 # Test goto with given/when
 977 {
 978     my $flag = 0;
 979     goto GIVEN1;
 980     $flag = 1;
 981     GIVEN1: given ($flag) {
 982         when (0) { break; }
 983         $flag = 2;
 984     }
 985     is($flag, 0, "goto GIVEN1");
 986 }
 987 {
 988     my $flag = 0;
 989     given ($flag) {
 990         when (0) { $flag = 1; }
 991         goto GIVEN2;
 992         $flag = 2;
 993     }
 994 GIVEN2:
 995     is($flag, 1, "goto inside given");
 996 }
 997 {
 998     my $flag = 0;
 999     given ($flag) {
1000         when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
1001         $flag = 3;
1002     }
1003 GIVEN3:
1004     is($flag, 1, "goto inside given and when");
1005 }
1006 {
1007     my $flag = 0;
1008     for ($flag) {
1009         when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
1010         $flag = 3;
1011     }
1012 GIVEN4:
1013     is($flag, 1, "goto inside for and when");
1014 }
1015 {
1016     my $flag = 0;
1017 GIVEN5:
1018     given ($flag) {
1019         when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
1020         when (1) { break; }
1021         $flag = 3;
1022     }
1023     is($flag, 1, "goto inside given and when to the given stmt");
1024 }
1025
1026 # test with unreified @_ in smart match [perl #71078]
1027 sub unreified_check { ok([@_] ~~ \@_) } # should always match
1028 unreified_check(1,2,"lala");
1029 unreified_check(1,2,undef);
1030 unreified_check(undef);
1031 unreified_check(undef,"");
1032
1033 # Test do { given } as a rvalue
1034
1035 {
1036     # Simple scalar
1037     my $lexical = 5;
1038     my @things = (11 .. 26); # 16 elements
1039     my @exp = (5, 16, 9);
1040     no warnings 'void';
1041     for (0, 1, 2) {
1042         my $scalar = do { given ($_) {
1043             when (0) { $lexical }
1044             when (2) { 'void'; 8, 9 }
1045             @things;
1046         } };
1047         is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
1048     }
1049 }
1050 {
1051     # Postfix scalar
1052     my $lexical = 5;
1053     my @exp = (5, 7, 9);
1054     for (0, 1, 2) {
1055         no warnings 'void';
1056         my $scalar = do { given ($_) {
1057             $lexical when 0;
1058             8, 9     when 2;
1059             6, 7;
1060         } };
1061         is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
1062     }
1063 }
1064 {
1065     # Default scalar
1066     my @exp = (5, 9, 9);
1067     for (0, 1, 2) {
1068         my $scalar = do { given ($_) {
1069             no warnings 'void';
1070             when (0) { 5 }
1071             default  { 8, 9 }
1072             6, 7;
1073         } };
1074         is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
1075     }
1076 }
1077 {
1078     # Simple list
1079     my @things = (11 .. 13);
1080     my @exp = ('3 4 5', '11 12 13', '8 9');
1081     for (0, 1, 2) {
1082         my @list = do { given ($_) {
1083             when (0) { 3 .. 5 }
1084             when (2) { my $fake = 'void'; 8, 9 }
1085             @things;
1086         } };
1087         is("@list", shift(@exp), "rvalue given - simple list [$_]");
1088     }
1089 }
1090 {
1091     # Postfix list
1092     my @things = (12);
1093     my @exp = ('3 4 5', '6 7', '12');
1094     for (0, 1, 2) {
1095         my @list = do { given ($_) {
1096             3 .. 5  when 0;
1097             @things when 2;
1098             6, 7;
1099         } };
1100         is("@list", shift(@exp), "rvalue given - postfix list [$_]");
1101     }
1102 }
1103 {
1104     # Default list
1105     my @things = (11 .. 20); # 10 elements
1106     my @exp = ('m o o', '8 10', '8 10');
1107     for (0, 1, 2) {
1108         my @list = do { given ($_) {
1109             when (0) { "moo" =~ /(.)/g }
1110             default  { 8, scalar(@things) }
1111             6, 7;
1112         } };
1113         is("@list", shift(@exp), "rvalue given - default list [$_]");
1114     }
1115 }
1116 {
1117     # Switch control
1118     my @exp = ('6 7', '', '6 7');
1119     for (0, 1, 2, 3) {
1120         my @list = do { given ($_) {
1121             continue when $_ <= 1;
1122             break    when 1;
1123             next     when 2;
1124             6, 7;
1125         } };
1126         is("@list", shift(@exp), "rvalue given - default list [$_]");
1127     }
1128 }
1129 {
1130     # Context propagation
1131     my $smart_hash = sub {
1132         do { given ($_[0]) {
1133             'undef' when undef;
1134             when ([ 1 .. 3 ]) { 1 .. 3 }
1135             when (4) { my $fake; do { 4, 5 } }
1136         } };
1137     };
1138
1139     my $scalar;
1140
1141     $scalar = $smart_hash->();
1142     is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
1143
1144     $scalar = $smart_hash->(4);
1145     is($scalar, 5,       "rvalue given - scalar context propagation [4]");
1146
1147     $scalar = $smart_hash->(999);
1148     is($scalar, undef,   "rvalue given - scalar context propagation [999]");
1149
1150     my @list;
1151
1152     @list = $smart_hash->();
1153     is("@list", 'undef', "rvalue given - list context propagation [undef]");
1154
1155     @list = $smart_hash->(2);
1156     is("@list", '1 2 3', "rvalue given - list context propagation [2]");
1157
1158     @list = $smart_hash->(4);
1159     is("@list", '4 5',   "rvalue given - list context propagation [4]");
1160
1161     @list = $smart_hash->(999);
1162     is("@list", '',      "rvalue given - list context propagation [999]");
1163 }
1164 {
1165     # Array slices
1166     my @list = 10 .. 15;
1167     my @in_list;
1168     my @in_slice;
1169     for (5, 10, 15) {
1170         given ($_) {
1171             when (@list) {
1172                 push @in_list, $_;
1173                 continue;
1174             }
1175             when (@list[0..2]) {
1176                 push @in_slice, $_;
1177             }
1178         }
1179     }
1180     is("@in_list", "10 15", "when(array)");
1181     is("@in_slice", "10", "when(array slice)");
1182 }
1183 {
1184     # Hash slices
1185     my %list = map { $_ => $_ } "a" .. "f";
1186     my @in_list;
1187     my @in_slice;
1188     for ("a", "e", "i") {
1189         given ($_) {
1190             when (%list) {
1191                 push @in_list, $_;
1192                 continue;
1193             }
1194             when (@list{"a".."c"}) {
1195                 push @in_slice, $_;
1196             }
1197         }
1198     }
1199     is("@in_list", "a e", "when(hash)");
1200     is("@in_slice", "a", "when(hash slice)");
1201 }
1202
1203 { # RT#84526 - Handle magical TARG
1204     my $x = my $y = "aaa";
1205     for ($x, $y) {
1206         given ($_) {
1207             is(pos, undef, "handle magical TARG");
1208             pos = 1;
1209         }
1210     }
1211 }
1212
1213 # Okay, that'll do for now. The intricacies of the smartmatch
1214 # semantics are tested in t/op/smartmatch.t
1215 __END__