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 no warnings 'experimental::smartmatch';
  12
  13 plan tests => 189;
  14
  15 # The behaviour of the feature pragma should be tested by lib/feature.t
  16 # using the tests in t/lib/feature/*. This file tests the behaviour of
  17 # the switch ops themselves.
  18
  19
  20 # Before loading feature, test the switch ops with CORE::
  21 CORE::given(3) {
  22     CORE::when(3) { pass "CORE::given and CORE::when"; continue }
  23     CORE::default { pass "continue (without feature) and CORE::default" }
  24 }
  25
  26
  27 use feature 'switch';
  28
  29 eval { continue };
  30 like($@, qr/^Can't "continue" outside/, "continue outside");
  31
  32 eval { break };
  33 like($@, qr/^Can't "break" outside/, "break outside");
  34
  35 # Scoping rules
  36
  37 {
  38     my $x = "foo";
  39     given(my $x = "bar") {
  40         is($x, "bar", "given scope starts");
  41     }
  42     is($x, "foo", "given scope ends");
  43 }
  44
  45 sub be_true {1}
  46
  47 given(my $x = "foo") {
  48     when(be_true(my $x = "bar")) {
  49         is($x, "bar", "given scope starts");
  50     }
  51     is($x, "foo", "given scope ends");
  52 }
  53
  54 $_ = "outside";
  55 given("inside") { check_outside1() }
  56 sub check_outside1 { is($_, "inside", "\$_ is not lexically scoped") }
  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 = 1;
 138     given (undef) { when(0) {$ok = 0} }
 139     is($ok, 1, "Given(undef) when(0)");
 140 }
 141 {
 142     no warnings "uninitialized";
 143     my $undef;
 144     my $ok = 1;
 145     given ($undef) { when(0) {$ok = 0} }
 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 = 1;
 163     given (undef) { when("") {$ok = 0} }
 164     is($ok, 1, 'Given(undef) when("")');
 165 }
 166 {
 167     no warnings "uninitialized";
 168     my $undef;
 169     my $ok = 1;
 170     given ($undef) { when("") {$ok = 0} }
 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 # Optimized-away comparisons
 392 {
 393     my $ok;
 394     given(23) {
 395         when (2 + 2 == 4) { $ok = 'y'; continue }
 396         when (2 + 2 == 5) { $ok = 'n' }
 397     }
 398     is($ok, 'y', "Optimized-away comparison");
 399 }
 400
 401 {
 402     my $ok;
 403     given(23) {
 404         when (scalar 24) { $ok = 'n'; continue }
 405         default { $ok = 'y' }
 406     }
 407     is($ok,'y','scalar()');
 408 }
 409
 410 # File tests
 411 #  (How to be both thorough and portable? Pinch a few ideas
 412 #  from t/op/filetest.t. We err on the side of portability for
 413 #  the time being.)
 414
 415 {
 416     my ($ok_d, $ok_f, $ok_r);
 417     given("op") {
 418         when(-d)  {$ok_d = 1; continue}
 419         when(!-f) {$ok_f = 1; continue}
 420         when(-r)  {$ok_r = 1; continue}
 421     }
 422     ok($ok_d, "Filetest -d");
 423     ok($ok_f, "Filetest -f");
 424     ok($ok_r, "Filetest -r");
 425 }
 426
 427 # Sub and method calls
 428 sub notfoo {"bar"}
 429 {
 430     my $ok = 0;
 431     given("foo") {
 432         when(notfoo()) {$ok = 1}
 433     }
 434     ok($ok, "Sub call acts as boolean")
 435 }
 436
 437 {
 438     my $ok = 0;
 439     given("foo") {
 440         when(main->notfoo()) {$ok = 1}
 441     }
 442     ok($ok, "Class-method call acts as boolean")
 443 }
 444
 445 {
 446     my $ok = 0;
 447     my $obj = bless [];
 448     given("foo") {
 449         when($obj->notfoo()) {$ok = 1}
 450     }
 451     ok($ok, "Object-method call acts as boolean")
 452 }
 453
 454 # Other things that should not be smart matched
 455 {
 456     my $ok = 0;
 457     given(12) {
 458         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
 459             $ok = 1;
 460         }
 461     }
 462     ok($ok, "bool not smartmatches");
 463 }
 464
 465 {
 466     my $ok = 0;
 467     given(0) {
 468         when(eof(DATA)) {
 469             $ok = 1;
 470         }
 471     }
 472     ok($ok, "eof() not smartmatched");
 473 }
 474
 475 {
 476     my $ok = 0;
 477     my %foo = ("bar", 0);
 478     given(0) {
 479         when(exists $foo{bar}) {
 480             $ok = 1;
 481         }
 482     }
 483     ok($ok, "exists() not smartmatched");
 484 }
 485
 486 {
 487     my $ok = 0;
 488     given(0) {
 489         when(defined $ok) {
 490             $ok = 1;
 491         }
 492     }
 493     ok($ok, "defined() not smartmatched");
 494 }
 495
 496 {
 497     my $ok = 1;
 498     given("foo") {
 499         when((1 == 1) && "bar") {
 500             $ok = 0;
 501         }
 502         when((1 == 1) && $_ eq "foo") {
 503             $ok = 2;
 504         }
 505     }
 506     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
 507 }
 508
 509 {
 510     my $n = 0;
 511     for my $l (qw(a b c d)) {
 512         given ($l) {
 513             when ($_ eq "b" .. $_ eq "c") { $n = 1 }
 514             default { $n = 0 }
 515         }
 516         ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
 517     }
 518 }
 519
 520 {
 521     my $n = 0;
 522     for my $l (qw(a b c d)) {
 523         given ($l) {
 524             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
 525             default { $n = 0 }
 526         }
 527         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
 528     }
 529 }
 530
 531 {
 532     my $ok = 0;
 533     given("foo") {
 534         when((1 == $ok) || "foo") {
 535             $ok = 1;
 536         }
 537     }
 538     ok($ok, '((1 == $ok) || "foo") smartmatched');
 539 }
 540
 541 {
 542     my $ok = 0;
 543     given("foo") {
 544         when((1 == $ok || undef) // "foo") {
 545             $ok = 1;
 546         }
 547     }
 548     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 549 }
 550
 551 # Make sure we aren't invoking the get-magic more than once
 552
 553 { # A helper class to count the number of accesses.
 554     package FetchCounter;
 555     sub TIESCALAR {
 556         my ($class) = @_;
 557         bless {value => undef, count => 0}, $class;
 558     }
 559     sub STORE {
 560         my ($self, $val) = @_;
 561         $self->{count} = 0;
 562         $self->{value} = $val;
 563     }
 564     sub FETCH {
 565         my ($self) = @_;
 566         # Avoid pre/post increment here
 567         $self->{count} = 1 + $self->{count};
 568         $self->{value};
 569     }
 570     sub count {
 571         my ($self) = @_;
 572         $self->{count};
 573     }
 574 }
 575
 576 my $f = tie my $v, "FetchCounter";
 577
 578 {   my $test_name = "Multiple FETCHes in given, due to aliasing";
 579     my $ok;
 580     given($v = 23) {
 581         when(undef) {}
 582         when(sub{0}->()) {}
 583         when(21) {}
 584         when("22") {}
 585         when(23) {$ok = 1}
 586         when(/24/) {$ok = 0}
 587     }
 588     is($ok, 1, "precheck: $test_name");
 589     is($f->count(), 4, $test_name);
 590 }
 591
 592 {   my $test_name = "Only one FETCH (numeric when)";
 593     my $ok;
 594     $v = 23;
 595     is($f->count(), 0, "Sanity check: $test_name");
 596     given(23) {
 597         when(undef) {}
 598         when(sub{0}->()) {}
 599         when(21) {}
 600         when("22") {}
 601         when($v) {$ok = 1}
 602         when(/24/) {$ok = 0}
 603     }
 604     is($ok, 1, "precheck: $test_name");
 605     is($f->count(), 1, $test_name);
 606 }
 607
 608 {   my $test_name = "Only one FETCH (string when)";
 609     my $ok;
 610     $v = "23";
 611     is($f->count(), 0, "Sanity check: $test_name");
 612     given("23") {
 613         when(undef) {}
 614         when(sub{0}->()) {}
 615         when("21") {}
 616         when("22") {}
 617         when($v) {$ok = 1}
 618         when(/24/) {$ok = 0}
 619     }
 620     is($ok, 1, "precheck: $test_name");
 621     is($f->count(), 1, $test_name);
 622 }
 623
 624 {   my $test_name = "Only one FETCH (undef)";
 625     my $ok;
 626     $v = undef;
 627     is($f->count(), 0, "Sanity check: $test_name");
 628     no warnings "uninitialized";
 629     given(my $undef) {
 630         when(sub{0}->()) {}
 631         when("21")  {}
 632         when("22")  {}
 633         when($v)    {$ok = 1}
 634         when(undef) {$ok = 0}
 635     }
 636     is($ok, 1, "precheck: $test_name");
 637     is($f->count(), 1, $test_name);
 638 }
 639
 640 # Loop topicalizer
 641 {
 642     my $first = 1;
 643     for (1, "two") {
 644         when ("two") {
 645             is($first, 0, "Loop: second");
 646             eval {break};
 647             like($@, qr/^Can't "break" in a loop topicalizer/,
 648                 q{Can't "break" in a loop topicalizer});
 649         }
 650         when (1) {
 651             is($first, 1, "Loop: first");
 652             $first = 0;
 653             # Implicit break is okay
 654         }
 655     }
 656 }
 657
 658 {
 659     my $first = 1;
 660     for $_ (1, "two") {
 661         when ("two") {
 662             is($first, 0, "Explicit \$_: second");
 663             eval {break};
 664             like($@, qr/^Can't "break" in a loop topicalizer/,
 665                 q{Can't "break" in a loop topicalizer});
 666         }
 667         when (1) {
 668             is($first, 1, "Explicit \$_: first");
 669             $first = 0;
 670             # Implicit break is okay
 671         }
 672     }
 673 }
 674
 675
 676 # Code references
 677 {
 678     my $called_foo = 0;
 679     sub foo {$called_foo = 1; "@_" eq "foo"}
 680     my $called_bar = 0;
 681     sub bar {$called_bar = 1; "@_" eq "bar"}
 682     my ($matched_foo, $matched_bar) = (0, 0);
 683     given("foo") {
 684         when(\&bar) {$matched_bar = 1}
 685         when(\&foo) {$matched_foo = 1}
 686     }
 687     is($called_foo, 1,  "foo() was called");
 688     is($called_bar, 1,  "bar() was called");
 689     is($matched_bar, 0, "bar didn't match");
 690     is($matched_foo, 1, "foo did match");
 691 }
 692
 693 sub contains_x {
 694     my $x = shift;
 695     return ($x =~ /x/);
 696 }
 697 {
 698     my ($ok1, $ok2) = (0,0);
 699     given("foxy!") {
 700         when(contains_x($_))
 701             { $ok1 = 1; continue }
 702         when(\&contains_x)
 703             { $ok2 = 1; continue }
 704     }
 705     is($ok1, 1, "Calling sub directly (true)");
 706     is($ok2, 1, "Calling sub indirectly (true)");
 707
 708     given("foggy") {
 709         when(contains_x($_))
 710             { $ok1 = 2; continue }
 711         when(\&contains_x)
 712             { $ok2 = 2; continue }
 713     }
 714     is($ok1, 1, "Calling sub directly (false)");
 715     is($ok2, 1, "Calling sub indirectly (false)");
 716 }
 717
 718 SKIP: {
 719     skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
 720     # Test overloading
 721     { package OverloadTest;
 722
 723       use overload '""' => sub{"string value of obj"};
 724       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 725
 726       use overload "~~" => sub {
 727           my ($self, $other, $reversed) = @_;
 728           if ($reversed) {
 729               $self->{left}  = $other;
 730               $self->{right} = $self;
 731               $self->{reversed} = 1;
 732           } else {
 733               $self->{left}  = $self;
 734               $self->{right} = $other;
 735               $self->{reversed} = 0;
 736           }
 737           $self->{called} = 1;
 738           return $self->{retval};
 739       };
 740
 741       sub new {
 742           my ($pkg, $retval) = @_;
 743           bless {
 744                  called => 0,
 745                  retval => $retval,
 746                 }, $pkg;
 747       }
 748   }
 749
 750     {
 751         my $test = "Overloaded obj in given (true)";
 752         my $obj = OverloadTest->new(1);
 753         my $matched;
 754         given($obj) {
 755             when ("other arg") {$matched = 1}
 756             default {$matched = 0}
 757         }
 758
 759         is($obj->{called}, 1, "$test: called");
 760         ok($matched, "$test: matched");
 761     }
 762
 763     {
 764         my $test = "Overloaded obj in given (false)";
 765         my $obj = OverloadTest->new(0);
 766         my $matched;
 767         given($obj) {
 768             when ("other arg") {$matched = 1}
 769         }
 770
 771         is($obj->{called}, 1, "$test: called");
 772         ok(!$matched, "$test: not matched");
 773     }
 774
 775     {
 776         my $test = "Overloaded obj in when (true)";
 777         my $obj = OverloadTest->new(1);
 778         my $matched;
 779         given("topic") {
 780             when ($obj) {$matched = 1}
 781             default {$matched = 0}
 782         }
 783
 784         is($obj->{called},  1, "$test: called");
 785         ok($matched, "$test: matched");
 786         is($obj->{left}, "topic", "$test: left");
 787         is($obj->{right}, "string value of obj", "$test: right");
 788         ok($obj->{reversed}, "$test: reversed");
 789     }
 790
 791     {
 792         my $test = "Overloaded obj in when (false)";
 793         my $obj = OverloadTest->new(0);
 794         my $matched;
 795         given("topic") {
 796             when ($obj) {$matched = 1}
 797             default {$matched = 0}
 798         }
 799
 800         is($obj->{called}, 1, "$test: called");
 801         ok(!$matched, "$test: not matched");
 802         is($obj->{left}, "topic", "$test: left");
 803         is($obj->{right}, "string value of obj", "$test: right");
 804         ok($obj->{reversed}, "$test: reversed");
 805     }
 806 }
 807
 808 # Postfix when
 809 {
 810     my $ok;
 811     given (undef) {
 812         $ok = 1 when undef;
 813     }
 814     is($ok, 1, "postfix undef");
 815 }
 816 {
 817     my $ok;
 818     given (2) {
 819         $ok += 1 when 7;
 820         $ok += 2 when 9.1685;
 821         $ok += 4 when $_ > 4;
 822         $ok += 8 when $_ < 2.5;
 823     }
 824     is($ok, 8, "postfix numeric");
 825 }
 826 {
 827     my $ok;
 828     given ("apple") {
 829         $ok = 1, continue when $_ eq "apple";
 830         $ok += 2;
 831         $ok = 0 when "banana";
 832     }
 833     is($ok, 3, "postfix string");
 834 }
 835 {
 836     my $ok;
 837     given ("pear") {
 838         do { $ok = 1; continue } when /pea/;
 839         $ok += 2;
 840         $ok = 0 when /pie/;
 841         default { $ok += 4 }
 842         $ok = 0;
 843     }
 844     is($ok, 7, "postfix regex");
 845 }
 846 # be_true is defined at the beginning of the file
 847 {
 848     my $x = "what";
 849     given(my $x = "foo") {
 850         do {
 851             is($x, "foo", "scope inside ... when my \$x = ...");
 852             continue;
 853         } when be_true(my $x = "bar");
 854         is($x, "bar", "scope after ... when my \$x = ...");
 855     }
 856 }
 857 {
 858     my $x = 0;
 859     given(my $x = 1) {
 860         my $x = 2, continue when be_true();
 861         is($x, undef, "scope after my \$x = ... when ...");
 862     }
 863 }
 864
 865 # Tests for last and next in when clauses
 866 my $letter;
 867
 868 $letter = '';
 869 for ("a".."e") {
 870     given ($_) {
 871         $letter = $_;
 872         when ("b") { last }
 873     }
 874     $letter = "z";
 875 }
 876 is($letter, "b", "last in when");
 877
 878 $letter = '';
 879 LETTER1: for ("a".."e") {
 880     given ($_) {
 881         $letter = $_;
 882         when ("b") { last LETTER1 }
 883     }
 884     $letter = "z";
 885 }
 886 is($letter, "b", "last LABEL in when");
 887
 888 $letter = '';
 889 for ("a".."e") {
 890     given ($_) {
 891         when (/b|d/) { next }
 892         $letter .= $_;
 893     }
 894     $letter .= ',';
 895 }
 896 is($letter, "a,c,e,", "next in when");
 897
 898 $letter = '';
 899 LETTER2: for ("a".."e") {
 900     given ($_) {
 901         when (/b|d/) { next LETTER2 }
 902         $letter .= $_;
 903     }
 904     $letter .= ',';
 905 }
 906 is($letter, "a,c,e,", "next LABEL in when");
 907
 908 # Test goto with given/when
 909 {
 910     my $flag = 0;
 911     goto GIVEN1;
 912     $flag = 1;
 913     GIVEN1: given ($flag) {
 914         when (0) { break; }
 915         $flag = 2;
 916     }
 917     is($flag, 0, "goto GIVEN1");
 918 }
 919 {
 920     my $flag = 0;
 921     given ($flag) {
 922         when (0) { $flag = 1; }
 923         goto GIVEN2;
 924         $flag = 2;
 925     }
 926 GIVEN2:
 927     is($flag, 1, "goto inside given");
 928 }
 929 {
 930     my $flag = 0;
 931     given ($flag) {
 932         when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
 933         $flag = 3;
 934     }
 935 GIVEN3:
 936     is($flag, 1, "goto inside given and when");
 937 }
 938 {
 939     my $flag = 0;
 940     for ($flag) {
 941         when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
 942         $flag = 3;
 943     }
 944 GIVEN4:
 945     is($flag, 1, "goto inside for and when");
 946 }
 947 {
 948     my $flag = 0;
 949 GIVEN5:
 950     given ($flag) {
 951         when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
 952         when (1) { break; }
 953         $flag = 3;
 954     }
 955     is($flag, 1, "goto inside given and when to the given stmt");
 956 }
 957
 958 # test with unreified @_ in smart match [perl #71078]
 959 sub unreified_check { ok([@_] ~~ \@_) } # should always match
 960 unreified_check(1,2,"lala");
 961 unreified_check(1,2,undef);
 962 unreified_check(undef);
 963 unreified_check(undef,"");
 964
 965 # Test do { given } as a rvalue
 966
 967 {
 968     # Simple scalar
 969     my $lexical = 5;
 970     my @things = (11 .. 26); # 16 elements
 971     my @exp = (5, 16, 9);
 972     no warnings 'void';
 973     for (0, 1, 2) {
 974         my $scalar = do { given ($_) {
 975             when (0) { $lexical }
 976             when (2) { 'void'; 8, 9 }
 977             @things;
 978         } };
 979         is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
 980     }
 981 }
 982 {
 983     # Postfix scalar
 984     my $lexical = 5;
 985     my @exp = (5, 7, 9);
 986     for (0, 1, 2) {
 987         no warnings 'void';
 988         my $scalar = do { given ($_) {
 989             $lexical when 0;
 990             8, 9     when 2;
 991             6, 7;
 992         } };
 993         is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
 994     }
 995 }
 996 {
 997     # Default scalar
 998     my @exp = (5, 9, 9);
 999     for (0, 1, 2) {
1000         my $scalar = do { given ($_) {
1001             no warnings 'void';
1002             when (0) { 5 }
1003             default  { 8, 9 }
1004             6, 7;
1005         } };
1006         is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
1007     }
1008 }
1009 {
1010     # Simple list
1011     my @things = (11 .. 13);
1012     my @exp = ('3 4 5', '11 12 13', '8 9');
1013     for (0, 1, 2) {
1014         my @list = do { given ($_) {
1015             when (0) { 3 .. 5 }
1016             when (2) { my $fake = 'void'; 8, 9 }
1017             @things;
1018         } };
1019         is("@list", shift(@exp), "rvalue given - simple list [$_]");
1020     }
1021 }
1022 {
1023     # Postfix list
1024     my @things = (12);
1025     my @exp = ('3 4 5', '6 7', '12');
1026     for (0, 1, 2) {
1027         my @list = do { given ($_) {
1028             3 .. 5  when 0;
1029             @things when 2;
1030             6, 7;
1031         } };
1032         is("@list", shift(@exp), "rvalue given - postfix list [$_]");
1033     }
1034 }
1035 {
1036     # Default list
1037     my @things = (11 .. 20); # 10 elements
1038     my @exp = ('m o o', '8 10', '8 10');
1039     for (0, 1, 2) {
1040         my @list = do { given ($_) {
1041             when (0) { "moo" =~ /(.)/g }
1042             default  { 8, scalar(@things) }
1043             6, 7;
1044         } };
1045         is("@list", shift(@exp), "rvalue given - default list [$_]");
1046     }
1047 }
1048 {
1049     # Switch control
1050     my @exp = ('6 7', '', '6 7');
1051     for (0, 1, 2, 3) {
1052         my @list = do { given ($_) {
1053             continue when $_ <= 1;
1054             break    when 1;
1055             next     when 2;
1056             6, 7;
1057         } };
1058         is("@list", shift(@exp), "rvalue given - default list [$_]");
1059     }
1060 }
1061 {
1062     # Context propagation
1063     my $smart_hash = sub {
1064         do { given ($_[0]) {
1065             'undef' when undef;
1066             when ([ 1 .. 3 ]) { 1 .. 3 }
1067             when (4) { my $fake; do { 4, 5 } }
1068         } };
1069     };
1070
1071     my $scalar;
1072
1073     $scalar = $smart_hash->();
1074     is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
1075
1076     $scalar = $smart_hash->(4);
1077     is($scalar, 5,       "rvalue given - scalar context propagation [4]");
1078
1079     $scalar = $smart_hash->(999);
1080     is($scalar, undef,   "rvalue given - scalar context propagation [999]");
1081
1082     my @list;
1083
1084     @list = $smart_hash->();
1085     is("@list", 'undef', "rvalue given - list context propagation [undef]");
1086
1087     @list = $smart_hash->(2);
1088     is("@list", '1 2 3', "rvalue given - list context propagation [2]");
1089
1090     @list = $smart_hash->(4);
1091     is("@list", '4 5',   "rvalue given - list context propagation [4]");
1092
1093     @list = $smart_hash->(999);
1094     is("@list", '',      "rvalue given - list context propagation [999]");
1095 }
1096 {
1097     # Array slices
1098     my @list = 10 .. 15;
1099     my @in_list;
1100     my @in_slice;
1101     for (5, 10, 15) {
1102         given ($_) {
1103             when (@list) {
1104                 push @in_list, $_;
1105                 continue;
1106             }
1107             when (@list[0..2]) {
1108                 push @in_slice, $_;
1109             }
1110         }
1111     }
1112     is("@in_list", "10 15", "when(array)");
1113     is("@in_slice", "10", "when(array slice)");
1114 }
1115 {
1116     # Hash slices
1117     my %list = map { $_ => $_ } "a" .. "f";
1118     my @in_list;
1119     my @in_slice;
1120     for ("a", "e", "i") {
1121         given ($_) {
1122             when (%list) {
1123                 push @in_list, $_;
1124                 continue;
1125             }
1126             when (@list{"a".."c"}) {
1127                 push @in_slice, $_;
1128             }
1129         }
1130     }
1131     is("@in_list", "a e", "when(hash)");
1132     is("@in_slice", "a", "when(hash slice)");
1133 }
1134
1135 { # RT#84526 - Handle magical TARG
1136     my $x = my $y = "aaa";
1137     for ($x, $y) {
1138         given ($_) {
1139             is(pos, undef, "handle magical TARG");
1140             pos = 1;
1141         }
1142     }
1143 }
1144
1145 # Test that returned values are correctly propagated through several context
1146 # levels (see RT #93548).
1147 {
1148     my $tester = sub {
1149         my $id = shift;
1150
1151         package fmurrr;
1152
1153         our ($when_loc, $given_loc, $ext_loc);
1154
1155         my $ext_lex    = 7;
1156         our $ext_glob  = 8;
1157         local $ext_loc = 9;
1158
1159         given ($id) {
1160             my $given_lex    = 4;
1161             our $given_glob  = 5;
1162             local $given_loc = 6;
1163
1164             when (0) { 0 }
1165
1166             when (1) { my $when_lex    = 1 }
1167             when (2) { our $when_glob  = 2 }
1168             when (3) { local $when_loc = 3 }
1169
1170             when (4) { $given_lex }
1171             when (5) { $given_glob }
1172             when (6) { $given_loc }
1173
1174             when (7) { $ext_lex }
1175             when (8) { $ext_glob }
1176             when (9) { $ext_loc }
1177
1178             'fallback';
1179         }
1180     };
1181
1182     my @descriptions = qw<
1183         constant
1184
1185         when-lexical
1186         when-global
1187         when-local
1188
1189         given-lexical
1190         given-global
1191         given-local
1192
1193         extern-lexical
1194         extern-global
1195         extern-local
1196     >;
1197
1198     for my $id (0 .. 9) {
1199         my $desc = $descriptions[$id];
1200
1201         my $res = $tester->($id);
1202         is $res, $id, "plain call - $desc";
1203
1204         $res = do {
1205             my $id_plus_1 = $id + 1;
1206             given ($id_plus_1) {
1207                 do {
1208                     when (/\d/) {
1209                         --$id_plus_1;
1210                         continue;
1211                         456;
1212                     }
1213                 };
1214                 default {
1215                     $tester->($id_plus_1);
1216                 }
1217                 'XXX';
1218             }
1219         };
1220         is $res, $id, "across continue and default - $desc";
1221     }
1222 }
1223
1224 # Check that values returned from given/when are destroyed at the right time.
1225 {
1226     {
1227         package Fmurrr;
1228
1229         sub new {
1230             bless {
1231                 flag => \($_[1]),
1232                 id   => $_[2],
1233             }, $_[0]
1234         }
1235
1236         sub DESTROY {
1237             ${$_[0]->{flag}}++;
1238         }
1239     }
1240
1241     my @descriptions = qw<
1242         when
1243         break
1244         continue
1245         default
1246     >;
1247
1248     for my $id (0 .. 3) {
1249         my $desc = $descriptions[$id];
1250
1251         my $destroyed = 0;
1252         my $res_id;
1253
1254         {
1255             my $res = do {
1256                 given ($id) {
1257                     my $x;
1258                     when (0) { Fmurrr->new($destroyed, 0) }
1259                     when (1) { my $y = Fmurrr->new($destroyed, 1); break }
1260                     when (2) { $x = Fmurrr->new($destroyed, 2); continue }
1261                     when (2) { $x }
1262                     default  { Fmurrr->new($destroyed, 3) }
1263                 }
1264             };
1265             $res_id = $res->{id};
1266         }
1267         $res_id = $id if $id == 1; # break doesn't return anything
1268
1269         is $res_id,    $id, "given/when returns the right object - $desc";
1270         is $destroyed, 1,   "given/when does not leak - $desc";
1271     };
1272 }
1273
1274 # break() must reset the stack
1275 {
1276     my @res = (1, do {
1277         given ("x") {
1278             2, 3, do {
1279                 when (/[a-z]/) {
1280                     4, 5, 6, break
1281                 }
1282             }
1283         }
1284     });
1285     is "@res", "1", "break resets the stack";
1286 }
1287
1288 # RT #94682:
1289 # must ensure $_ is initialised and cleared at start/end of given block
1290
1291 {
1292     package RT94682;
1293
1294     my $d = 0;
1295     sub DESTROY { $d++ };
1296
1297     sub f2 {
1298         no warnings 'experimental::lexical_topic';
1299         local $_ = 5;
1300         given(bless [7]) {
1301             ::is($_->[0], 7, "is [7]");
1302         }
1303         ::is($_, 5, "is 5");
1304         ::is($d, 1, "DESTROY called once");
1305     }
1306     f2();
1307 }
1308
1309
1310
1311 # Okay, that'll do for now. The intricacies of the smartmatch
1312 # semantics are tested in t/op/smartmatch.t. Taintedness of
1313 # returned values is checked in t/op/taint.t.
1314 __END__