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 => 201;
  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 {
  59     no warnings 'experimental::lexical_topic';
  60     my $_ = "outside";
  61     given("inside") { check_outside2() }
  62     sub check_outside2 {
  63         is($_, "outside", "\$_ lexically scoped (lexical \$_)")
  64     }
  65 }
  66
  67 # Basic string/numeric comparisons and control flow
  68
  69 {
  70     my $ok;
  71     given(3) {
  72         when(2) { $ok = 'two'; }
  73         when(3) { $ok = 'three'; }
  74         when(4) { $ok = 'four'; }
  75         default { $ok = 'd'; }
  76     }
  77     is($ok, 'three', "numeric comparison");
  78 }
  79
  80 {
  81     my $ok;
  82     use integer;
  83     given(3.14159265) {
  84         when(2) { $ok = 'two'; }
  85         when(3) { $ok = 'three'; }
  86         when(4) { $ok = 'four'; }
  87         default { $ok = 'd'; }
  88     }
  89     is($ok, 'three', "integer comparison");
  90 }
  91
  92 {
  93     my ($ok1, $ok2);
  94     given(3) {
  95         when(3.1)   { $ok1 = 'n'; }
  96         when(3.0)   { $ok1 = 'y'; continue }
  97         when("3.0") { $ok2 = 'y'; }
  98         default     { $ok2 = 'n'; }
  99     }
 100     is($ok1, 'y', "more numeric (pt. 1)");
 101     is($ok2, 'y', "more numeric (pt. 2)");
 102 }
 103
 104 {
 105     my $ok;
 106     given("c") {
 107         when("b") { $ok = 'B'; }
 108         when("c") { $ok = 'C'; }
 109         when("d") { $ok = 'D'; }
 110         default   { $ok = 'def'; }
 111     }
 112     is($ok, 'C', "string comparison");
 113 }
 114
 115 {
 116     my $ok;
 117     given("c") {
 118         when("b") { $ok = 'B'; }
 119         when("c") { $ok = 'C'; continue }
 120         when("c") { $ok = 'CC'; }
 121         default   { $ok = 'D'; }
 122     }
 123     is($ok, 'CC', "simple continue");
 124 }
 125
 126 # Definedness
 127 {
 128     my $ok = 1;
 129     given (0) { when(undef) {$ok = 0} }
 130     is($ok, 1, "Given(0) when(undef)");
 131 }
 132 {
 133     my $undef;
 134     my $ok = 1;
 135     given (0) { when($undef) {$ok = 0} }
 136     is($ok, 1, 'Given(0) when($undef)');
 137 }
 138 {
 139     my $undef;
 140     my $ok = 0;
 141     given (0) { when($undef++) {$ok = 1} }
 142     is($ok, 1, "Given(0) when($undef++)");
 143 }
 144 {
 145     no warnings "uninitialized";
 146     my $ok = 1;
 147     given (undef) { when(0) {$ok = 0} }
 148     is($ok, 1, "Given(undef) when(0)");
 149 }
 150 {
 151     no warnings "uninitialized";
 152     my $undef;
 153     my $ok = 1;
 154     given ($undef) { when(0) {$ok = 0} }
 155     is($ok, 1, 'Given($undef) when(0)');
 156 }
 157 ########
 158 {
 159     my $ok = 1;
 160     given ("") { when(undef) {$ok = 0} }
 161     is($ok, 1, 'Given("") when(undef)');
 162 }
 163 {
 164     my $undef;
 165     my $ok = 1;
 166     given ("") { when($undef) {$ok = 0} }
 167     is($ok, 1, 'Given("") when($undef)');
 168 }
 169 {
 170     no warnings "uninitialized";
 171     my $ok = 1;
 172     given (undef) { when("") {$ok = 0} }
 173     is($ok, 1, 'Given(undef) when("")');
 174 }
 175 {
 176     no warnings "uninitialized";
 177     my $undef;
 178     my $ok = 1;
 179     given ($undef) { when("") {$ok = 0} }
 180     is($ok, 1, 'Given($undef) when("")');
 181 }
 182 ########
 183 {
 184     my $ok = 0;
 185     given (undef) { when(undef) {$ok = 1} }
 186     is($ok, 1, "Given(undef) when(undef)");
 187 }
 188 {
 189     my $undef;
 190     my $ok = 0;
 191     given (undef) { when($undef) {$ok = 1} }
 192     is($ok, 1, 'Given(undef) when($undef)');
 193 }
 194 {
 195     my $undef;
 196     my $ok = 0;
 197     given ($undef) { when(undef) {$ok = 1} }
 198     is($ok, 1, 'Given($undef) when(undef)');
 199 }
 200 {
 201     my $undef;
 202     my $ok = 0;
 203     given ($undef) { when($undef) {$ok = 1} }
 204     is($ok, 1, 'Given($undef) when($undef)');
 205 }
 206
 207
 208 # Regular expressions
 209 {
 210     my ($ok1, $ok2);
 211     given("Hello, world!") {
 212         when(/lo/)
 213             { $ok1 = 'y'; continue}
 214         when(/no/)
 215             { $ok1 = 'n'; continue}
 216         when(/^(Hello,|Goodbye cruel) world[!.?]/)
 217             { $ok2 = 'Y'; continue}
 218         when(/^(Hello cruel|Goodbye,) world[!.?]/)
 219             { $ok2 = 'n'; continue}
 220     }
 221     is($ok1, 'y', "regex 1");
 222     is($ok2, 'Y', "regex 2");
 223 }
 224
 225 # Comparisons
 226 {
 227     my $test = "explicit numeric comparison (<)";
 228     my $twenty_five = 25;
 229     my $ok;
 230     given($twenty_five) {
 231         when ($_ < 10) { $ok = "ten" }
 232         when ($_ < 20) { $ok = "twenty" }
 233         when ($_ < 30) { $ok = "thirty" }
 234         when ($_ < 40) { $ok = "forty" }
 235         default        { $ok = "default" }
 236     }
 237     is($ok, "thirty", $test);
 238 }
 239
 240 {
 241     use integer;
 242     my $test = "explicit numeric comparison (integer <)";
 243     my $twenty_five = 25;
 244     my $ok;
 245     given($twenty_five) {
 246         when ($_ < 10) { $ok = "ten" }
 247         when ($_ < 20) { $ok = "twenty" }
 248         when ($_ < 30) { $ok = "thirty" }
 249         when ($_ < 40) { $ok = "forty" }
 250         default        { $ok = "default" }
 251     }
 252     is($ok, "thirty", $test);
 253 }
 254
 255 {
 256     my $test = "explicit numeric comparison (<=)";
 257     my $twenty_five = 25;
 258     my $ok;
 259     given($twenty_five) {
 260         when ($_ <= 10) { $ok = "ten" }
 261         when ($_ <= 20) { $ok = "twenty" }
 262         when ($_ <= 30) { $ok = "thirty" }
 263         when ($_ <= 40) { $ok = "forty" }
 264         default         { $ok = "default" }
 265     }
 266     is($ok, "thirty", $test);
 267 }
 268
 269 {
 270     use integer;
 271     my $test = "explicit numeric comparison (integer <=)";
 272     my $twenty_five = 25;
 273     my $ok;
 274     given($twenty_five) {
 275         when ($_ <= 10) { $ok = "ten" }
 276         when ($_ <= 20) { $ok = "twenty" }
 277         when ($_ <= 30) { $ok = "thirty" }
 278         when ($_ <= 40) { $ok = "forty" }
 279         default         { $ok = "default" }
 280     }
 281     is($ok, "thirty", $test);
 282 }
 283
 284
 285 {
 286     my $test = "explicit numeric comparison (>)";
 287     my $twenty_five = 25;
 288     my $ok;
 289     given($twenty_five) {
 290         when ($_ > 40) { $ok = "forty" }
 291         when ($_ > 30) { $ok = "thirty" }
 292         when ($_ > 20) { $ok = "twenty" }
 293         when ($_ > 10) { $ok = "ten" }
 294         default        { $ok = "default" }
 295     }
 296     is($ok, "twenty", $test);
 297 }
 298
 299 {
 300     my $test = "explicit numeric comparison (>=)";
 301     my $twenty_five = 25;
 302     my $ok;
 303     given($twenty_five) {
 304         when ($_ >= 40) { $ok = "forty" }
 305         when ($_ >= 30) { $ok = "thirty" }
 306         when ($_ >= 20) { $ok = "twenty" }
 307         when ($_ >= 10) { $ok = "ten" }
 308         default         { $ok = "default" }
 309     }
 310     is($ok, "twenty", $test);
 311 }
 312
 313 {
 314     use integer;
 315     my $test = "explicit numeric comparison (integer >)";
 316     my $twenty_five = 25;
 317     my $ok;
 318     given($twenty_five) {
 319         when ($_ > 40) { $ok = "forty" }
 320         when ($_ > 30) { $ok = "thirty" }
 321         when ($_ > 20) { $ok = "twenty" }
 322         when ($_ > 10) { $ok = "ten" }
 323         default        { $ok = "default" }
 324     }
 325     is($ok, "twenty", $test);
 326 }
 327
 328 {
 329     use integer;
 330     my $test = "explicit numeric comparison (integer >=)";
 331     my $twenty_five = 25;
 332     my $ok;
 333     given($twenty_five) {
 334         when ($_ >= 40) { $ok = "forty" }
 335         when ($_ >= 30) { $ok = "thirty" }
 336         when ($_ >= 20) { $ok = "twenty" }
 337         when ($_ >= 10) { $ok = "ten" }
 338         default         { $ok = "default" }
 339     }
 340     is($ok, "twenty", $test);
 341 }
 342
 343
 344 {
 345     my $test = "explicit string comparison (lt)";
 346     my $twenty_five = "25";
 347     my $ok;
 348     given($twenty_five) {
 349         when ($_ lt "10") { $ok = "ten" }
 350         when ($_ lt "20") { $ok = "twenty" }
 351         when ($_ lt "30") { $ok = "thirty" }
 352         when ($_ lt "40") { $ok = "forty" }
 353         default           { $ok = "default" }
 354     }
 355     is($ok, "thirty", $test);
 356 }
 357
 358 {
 359     my $test = "explicit string comparison (le)";
 360     my $twenty_five = "25";
 361     my $ok;
 362     given($twenty_five) {
 363         when ($_ le "10") { $ok = "ten" }
 364         when ($_ le "20") { $ok = "twenty" }
 365         when ($_ le "30") { $ok = "thirty" }
 366         when ($_ le "40") { $ok = "forty" }
 367         default           { $ok = "default" }
 368     }
 369     is($ok, "thirty", $test);
 370 }
 371
 372 {
 373     my $test = "explicit string comparison (gt)";
 374     my $twenty_five = 25;
 375     my $ok;
 376     given($twenty_five) {
 377         when ($_ ge "40") { $ok = "forty" }
 378         when ($_ ge "30") { $ok = "thirty" }
 379         when ($_ ge "20") { $ok = "twenty" }
 380         when ($_ ge "10") { $ok = "ten" }
 381         default           { $ok = "default" }
 382     }
 383     is($ok, "twenty", $test);
 384 }
 385
 386 {
 387     my $test = "explicit string comparison (ge)";
 388     my $twenty_five = 25;
 389     my $ok;
 390     given($twenty_five) {
 391         when ($_ ge "40") { $ok = "forty" }
 392         when ($_ ge "30") { $ok = "thirty" }
 393         when ($_ ge "20") { $ok = "twenty" }
 394         when ($_ ge "10") { $ok = "ten" }
 395         default           { $ok = "default" }
 396     }
 397     is($ok, "twenty", $test);
 398 }
 399
 400 # Make sure it still works with a lexical $_:
 401 {
 402     no warnings 'experimental::lexical_topic';
 403     my $_;
 404     my $test = "explicit comparison with lexical \$_";
 405     my $twenty_five = 25;
 406     my $ok;
 407     given($twenty_five) {
 408         when ($_ ge "40") { $ok = "forty" }
 409         when ($_ ge "30") { $ok = "thirty" }
 410         when ($_ ge "20") { $ok = "twenty" }
 411         when ($_ ge "10") { $ok = "ten" }
 412         default           { $ok = "default" }
 413     }
 414     is($ok, "twenty", $test);
 415 }
 416
 417 # Optimized-away comparisons
 418 {
 419     my $ok;
 420     given(23) {
 421         when (2 + 2 == 4) { $ok = 'y'; continue }
 422         when (2 + 2 == 5) { $ok = 'n' }
 423     }
 424     is($ok, 'y', "Optimized-away comparison");
 425 }
 426
 427 {
 428     my $ok;
 429     given(23) {
 430         when (scalar 24) { $ok = 'n'; continue }
 431         default { $ok = 'y' }
 432     }
 433     is($ok,'y','scalar()');
 434 }
 435
 436 # File tests
 437 #  (How to be both thorough and portable? Pinch a few ideas
 438 #  from t/op/filetest.t. We err on the side of portability for
 439 #  the time being.)
 440
 441 {
 442     my ($ok_d, $ok_f, $ok_r);
 443     given("op") {
 444         when(-d)  {$ok_d = 1; continue}
 445         when(!-f) {$ok_f = 1; continue}
 446         when(-r)  {$ok_r = 1; continue}
 447     }
 448     ok($ok_d, "Filetest -d");
 449     ok($ok_f, "Filetest -f");
 450     ok($ok_r, "Filetest -r");
 451 }
 452
 453 # Sub and method calls
 454 sub notfoo {"bar"}
 455 {
 456     my $ok = 0;
 457     given("foo") {
 458         when(notfoo()) {$ok = 1}
 459     }
 460     ok($ok, "Sub call acts as boolean")
 461 }
 462
 463 {
 464     my $ok = 0;
 465     given("foo") {
 466         when(main->notfoo()) {$ok = 1}
 467     }
 468     ok($ok, "Class-method call acts as boolean")
 469 }
 470
 471 {
 472     my $ok = 0;
 473     my $obj = bless [];
 474     given("foo") {
 475         when($obj->notfoo()) {$ok = 1}
 476     }
 477     ok($ok, "Object-method call acts as boolean")
 478 }
 479
 480 # Other things that should not be smart matched
 481 {
 482     my $ok = 0;
 483     given(12) {
 484         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
 485             $ok = 1;
 486         }
 487     }
 488     ok($ok, "bool not smartmatches");
 489 }
 490
 491 {
 492     my $ok = 0;
 493     given(0) {
 494         when(eof(DATA)) {
 495             $ok = 1;
 496         }
 497     }
 498     ok($ok, "eof() not smartmatched");
 499 }
 500
 501 {
 502     my $ok = 0;
 503     my %foo = ("bar", 0);
 504     given(0) {
 505         when(exists $foo{bar}) {
 506             $ok = 1;
 507         }
 508     }
 509     ok($ok, "exists() not smartmatched");
 510 }
 511
 512 {
 513     my $ok = 0;
 514     given(0) {
 515         when(defined $ok) {
 516             $ok = 1;
 517         }
 518     }
 519     ok($ok, "defined() not smartmatched");
 520 }
 521
 522 {
 523     my $ok = 1;
 524     given("foo") {
 525         when((1 == 1) && "bar") {
 526             $ok = 0;
 527         }
 528         when((1 == 1) && $_ eq "foo") {
 529             $ok = 2;
 530         }
 531     }
 532     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
 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 $n = 0;
 548     for my $l (qw(a b c d)) {
 549         given ($l) {
 550             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
 551             default { $n = 0 }
 552         }
 553         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
 554     }
 555 }
 556
 557 {
 558     my $ok = 0;
 559     given("foo") {
 560         when((1 == $ok) || "foo") {
 561             $ok = 1;
 562         }
 563     }
 564     ok($ok, '((1 == $ok) || "foo") smartmatched');
 565 }
 566
 567 {
 568     my $ok = 0;
 569     given("foo") {
 570         when((1 == $ok || undef) // "foo") {
 571             $ok = 1;
 572         }
 573     }
 574     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 575 }
 576
 577 # Make sure we aren't invoking the get-magic more than once
 578
 579 { # A helper class to count the number of accesses.
 580     package FetchCounter;
 581     sub TIESCALAR {
 582         my ($class) = @_;
 583         bless {value => undef, count => 0}, $class;
 584     }
 585     sub STORE {
 586         my ($self, $val) = @_;
 587         $self->{count} = 0;
 588         $self->{value} = $val;
 589     }
 590     sub FETCH {
 591         my ($self) = @_;
 592         # Avoid pre/post increment here
 593         $self->{count} = 1 + $self->{count};
 594         $self->{value};
 595     }
 596     sub count {
 597         my ($self) = @_;
 598         $self->{count};
 599     }
 600 }
 601
 602 my $f = tie my $v, "FetchCounter";
 603
 604 {   my $test_name = "Multiple FETCHes in given, due to aliasing";
 605     my $ok;
 606     given($v = 23) {
 607         when(undef) {}
 608         when(sub{0}->()) {}
 609         when(21) {}
 610         when("22") {}
 611         when(23) {$ok = 1}
 612         when(/24/) {$ok = 0}
 613     }
 614     is($ok, 1, "precheck: $test_name");
 615     is($f->count(), 4, $test_name);
 616 }
 617
 618 {   my $test_name = "Only one FETCH (numeric when)";
 619     my $ok;
 620     $v = 23;
 621     is($f->count(), 0, "Sanity check: $test_name");
 622     given(23) {
 623         when(undef) {}
 624         when(sub{0}->()) {}
 625         when(21) {}
 626         when("22") {}
 627         when($v) {$ok = 1}
 628         when(/24/) {$ok = 0}
 629     }
 630     is($ok, 1, "precheck: $test_name");
 631     is($f->count(), 1, $test_name);
 632 }
 633
 634 {   my $test_name = "Only one FETCH (string when)";
 635     my $ok;
 636     $v = "23";
 637     is($f->count(), 0, "Sanity check: $test_name");
 638     given("23") {
 639         when(undef) {}
 640         when(sub{0}->()) {}
 641         when("21") {}
 642         when("22") {}
 643         when($v) {$ok = 1}
 644         when(/24/) {$ok = 0}
 645     }
 646     is($ok, 1, "precheck: $test_name");
 647     is($f->count(), 1, $test_name);
 648 }
 649
 650 {   my $test_name = "Only one FETCH (undef)";
 651     my $ok;
 652     $v = undef;
 653     is($f->count(), 0, "Sanity check: $test_name");
 654     no warnings "uninitialized";
 655     given(my $undef) {
 656         when(sub{0}->()) {}
 657         when("21")  {}
 658         when("22")  {}
 659         when($v)    {$ok = 1}
 660         when(undef) {$ok = 0}
 661     }
 662     is($ok, 1, "precheck: $test_name");
 663     is($f->count(), 1, $test_name);
 664 }
 665
 666 # Loop topicalizer
 667 {
 668     my $first = 1;
 669     for (1, "two") {
 670         when ("two") {
 671             is($first, 0, "Loop: second");
 672             eval {break};
 673             like($@, qr/^Can't "break" in a loop topicalizer/,
 674                 q{Can't "break" in a loop topicalizer});
 675         }
 676         when (1) {
 677             is($first, 1, "Loop: first");
 678             $first = 0;
 679             # Implicit break is okay
 680         }
 681     }
 682 }
 683
 684 {
 685     my $first = 1;
 686     for $_ (1, "two") {
 687         when ("two") {
 688             is($first, 0, "Explicit \$_: second");
 689             eval {break};
 690             like($@, qr/^Can't "break" in a loop topicalizer/,
 691                 q{Can't "break" in a loop topicalizer});
 692         }
 693         when (1) {
 694             is($first, 1, "Explicit \$_: first");
 695             $first = 0;
 696             # Implicit break is okay
 697         }
 698     }
 699 }
 700
 701 {
 702     my $first = 1;
 703     no warnings 'experimental::lexical_topic';
 704     my $_;
 705     for (1, "two") {
 706         when ("two") {
 707             is($first, 0, "Implicitly lexical loop: second");
 708             eval {break};
 709             like($@, qr/^Can't "break" in a loop topicalizer/,
 710                 q{Can't "break" in a loop topicalizer});
 711         }
 712         when (1) {
 713             is($first, 1, "Implicitly lexical loop: first");
 714             $first = 0;
 715             # Implicit break is okay
 716         }
 717     }
 718 }
 719
 720 {
 721     my $first = 1;
 722     no warnings 'experimental::lexical_topic';
 723     my $_;
 724     for $_ (1, "two") {
 725         when ("two") {
 726             is($first, 0, "Implicitly lexical, explicit \$_: second");
 727             eval {break};
 728             like($@, qr/^Can't "break" in a loop topicalizer/,
 729                 q{Can't "break" in a loop topicalizer});
 730         }
 731         when (1) {
 732             is($first, 1, "Implicitly lexical, explicit \$_: first");
 733             $first = 0;
 734             # Implicit break is okay
 735         }
 736     }
 737 }
 738
 739 {
 740     my $first = 1;
 741     no warnings 'experimental::lexical_topic';
 742     for my $_ (1, "two") {
 743         when ("two") {
 744             is($first, 0, "Lexical loop: second");
 745             eval {break};
 746             like($@, qr/^Can't "break" in a loop topicalizer/,
 747                 q{Can't "break" in a loop topicalizer});
 748         }
 749         when (1) {
 750             is($first, 1, "Lexical loop: first");
 751             $first = 0;
 752             # Implicit break is okay
 753         }
 754     }
 755 }
 756
 757
 758 # Code references
 759 {
 760     my $called_foo = 0;
 761     sub foo {$called_foo = 1; "@_" eq "foo"}
 762     my $called_bar = 0;
 763     sub bar {$called_bar = 1; "@_" eq "bar"}
 764     my ($matched_foo, $matched_bar) = (0, 0);
 765     given("foo") {
 766         when(\&bar) {$matched_bar = 1}
 767         when(\&foo) {$matched_foo = 1}
 768     }
 769     is($called_foo, 1,  "foo() was called");
 770     is($called_bar, 1,  "bar() was called");
 771     is($matched_bar, 0, "bar didn't match");
 772     is($matched_foo, 1, "foo did match");
 773 }
 774
 775 sub contains_x {
 776     my $x = shift;
 777     return ($x =~ /x/);
 778 }
 779 {
 780     my ($ok1, $ok2) = (0,0);
 781     given("foxy!") {
 782         when(contains_x($_))
 783             { $ok1 = 1; continue }
 784         when(\&contains_x)
 785             { $ok2 = 1; continue }
 786     }
 787     is($ok1, 1, "Calling sub directly (true)");
 788     is($ok2, 1, "Calling sub indirectly (true)");
 789
 790     given("foggy") {
 791         when(contains_x($_))
 792             { $ok1 = 2; continue }
 793         when(\&contains_x)
 794             { $ok2 = 2; continue }
 795     }
 796     is($ok1, 1, "Calling sub directly (false)");
 797     is($ok2, 1, "Calling sub indirectly (false)");
 798 }
 799
 800 SKIP: {
 801     skip_if_miniperl("no dynamic loading on miniperl, no Scalar::Util", 14);
 802     # Test overloading
 803     { package OverloadTest;
 804
 805       use overload '""' => sub{"string value of obj"};
 806       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 807
 808       use overload "~~" => sub {
 809           my ($self, $other, $reversed) = @_;
 810           if ($reversed) {
 811               $self->{left}  = $other;
 812               $self->{right} = $self;
 813               $self->{reversed} = 1;
 814           } else {
 815               $self->{left}  = $self;
 816               $self->{right} = $other;
 817               $self->{reversed} = 0;
 818           }
 819           $self->{called} = 1;
 820           return $self->{retval};
 821       };
 822
 823       sub new {
 824           my ($pkg, $retval) = @_;
 825           bless {
 826                  called => 0,
 827                  retval => $retval,
 828                 }, $pkg;
 829       }
 830   }
 831
 832     {
 833         my $test = "Overloaded obj in given (true)";
 834         my $obj = OverloadTest->new(1);
 835         my $matched;
 836         given($obj) {
 837             when ("other arg") {$matched = 1}
 838             default {$matched = 0}
 839         }
 840
 841         is($obj->{called}, 1, "$test: called");
 842         ok($matched, "$test: matched");
 843     }
 844
 845     {
 846         my $test = "Overloaded obj in given (false)";
 847         my $obj = OverloadTest->new(0);
 848         my $matched;
 849         given($obj) {
 850             when ("other arg") {$matched = 1}
 851         }
 852
 853         is($obj->{called}, 1, "$test: called");
 854         ok(!$matched, "$test: not matched");
 855     }
 856
 857     {
 858         my $test = "Overloaded obj in when (true)";
 859         my $obj = OverloadTest->new(1);
 860         my $matched;
 861         given("topic") {
 862             when ($obj) {$matched = 1}
 863             default {$matched = 0}
 864         }
 865
 866         is($obj->{called},  1, "$test: called");
 867         ok($matched, "$test: matched");
 868         is($obj->{left}, "topic", "$test: left");
 869         is($obj->{right}, "string value of obj", "$test: right");
 870         ok($obj->{reversed}, "$test: reversed");
 871     }
 872
 873     {
 874         my $test = "Overloaded obj in when (false)";
 875         my $obj = OverloadTest->new(0);
 876         my $matched;
 877         given("topic") {
 878             when ($obj) {$matched = 1}
 879             default {$matched = 0}
 880         }
 881
 882         is($obj->{called}, 1, "$test: called");
 883         ok(!$matched, "$test: not matched");
 884         is($obj->{left}, "topic", "$test: left");
 885         is($obj->{right}, "string value of obj", "$test: right");
 886         ok($obj->{reversed}, "$test: reversed");
 887     }
 888 }
 889
 890 # Postfix when
 891 {
 892     my $ok;
 893     given (undef) {
 894         $ok = 1 when undef;
 895     }
 896     is($ok, 1, "postfix undef");
 897 }
 898 {
 899     my $ok;
 900     given (2) {
 901         $ok += 1 when 7;
 902         $ok += 2 when 9.1685;
 903         $ok += 4 when $_ > 4;
 904         $ok += 8 when $_ < 2.5;
 905     }
 906     is($ok, 8, "postfix numeric");
 907 }
 908 {
 909     my $ok;
 910     given ("apple") {
 911         $ok = 1, continue when $_ eq "apple";
 912         $ok += 2;
 913         $ok = 0 when "banana";
 914     }
 915     is($ok, 3, "postfix string");
 916 }
 917 {
 918     my $ok;
 919     given ("pear") {
 920         do { $ok = 1; continue } when /pea/;
 921         $ok += 2;
 922         $ok = 0 when /pie/;
 923         default { $ok += 4 }
 924         $ok = 0;
 925     }
 926     is($ok, 7, "postfix regex");
 927 }
 928 # be_true is defined at the beginning of the file
 929 {
 930     my $x = "what";
 931     given(my $x = "foo") {
 932         do {
 933             is($x, "foo", "scope inside ... when my \$x = ...");
 934             continue;
 935         } when be_true(my $x = "bar");
 936         is($x, "bar", "scope after ... when my \$x = ...");
 937     }
 938 }
 939 {
 940     my $x = 0;
 941     given(my $x = 1) {
 942         my $x = 2, continue when be_true();
 943         is($x, undef, "scope after my \$x = ... when ...");
 944     }
 945 }
 946
 947 # Tests for last and next in when clauses
 948 my $letter;
 949
 950 $letter = '';
 951 for ("a".."e") {
 952     given ($_) {
 953         $letter = $_;
 954         when ("b") { last }
 955     }
 956     $letter = "z";
 957 }
 958 is($letter, "b", "last in when");
 959
 960 $letter = '';
 961 LETTER1: for ("a".."e") {
 962     given ($_) {
 963         $letter = $_;
 964         when ("b") { last LETTER1 }
 965     }
 966     $letter = "z";
 967 }
 968 is($letter, "b", "last LABEL in when");
 969
 970 $letter = '';
 971 for ("a".."e") {
 972     given ($_) {
 973         when (/b|d/) { next }
 974         $letter .= $_;
 975     }
 976     $letter .= ',';
 977 }
 978 is($letter, "a,c,e,", "next in when");
 979
 980 $letter = '';
 981 LETTER2: for ("a".."e") {
 982     given ($_) {
 983         when (/b|d/) { next LETTER2 }
 984         $letter .= $_;
 985     }
 986     $letter .= ',';
 987 }
 988 is($letter, "a,c,e,", "next LABEL in when");
 989
 990 # Test goto with given/when
 991 {
 992     my $flag = 0;
 993     goto GIVEN1;
 994     $flag = 1;
 995     GIVEN1: given ($flag) {
 996         when (0) { break; }
 997         $flag = 2;
 998     }
 999     is($flag, 0, "goto GIVEN1");
1000 }
1001 {
1002     my $flag = 0;
1003     given ($flag) {
1004         when (0) { $flag = 1; }
1005         goto GIVEN2;
1006         $flag = 2;
1007     }
1008 GIVEN2:
1009     is($flag, 1, "goto inside given");
1010 }
1011 {
1012     my $flag = 0;
1013     given ($flag) {
1014         when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
1015         $flag = 3;
1016     }
1017 GIVEN3:
1018     is($flag, 1, "goto inside given and when");
1019 }
1020 {
1021     my $flag = 0;
1022     for ($flag) {
1023         when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
1024         $flag = 3;
1025     }
1026 GIVEN4:
1027     is($flag, 1, "goto inside for and when");
1028 }
1029 {
1030     my $flag = 0;
1031 GIVEN5:
1032     given ($flag) {
1033         when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
1034         when (1) { break; }
1035         $flag = 3;
1036     }
1037     is($flag, 1, "goto inside given and when to the given stmt");
1038 }
1039
1040 # test with unreified @_ in smart match [perl #71078]
1041 sub unreified_check { ok([@_] ~~ \@_) } # should always match
1042 unreified_check(1,2,"lala");
1043 unreified_check(1,2,undef);
1044 unreified_check(undef);
1045 unreified_check(undef,"");
1046
1047 # Test do { given } as a rvalue
1048
1049 {
1050     # Simple scalar
1051     my $lexical = 5;
1052     my @things = (11 .. 26); # 16 elements
1053     my @exp = (5, 16, 9);
1054     no warnings 'void';
1055     for (0, 1, 2) {
1056         my $scalar = do { given ($_) {
1057             when (0) { $lexical }
1058             when (2) { 'void'; 8, 9 }
1059             @things;
1060         } };
1061         is($scalar, shift(@exp), "rvalue given - simple scalar [$_]");
1062     }
1063 }
1064 {
1065     # Postfix scalar
1066     my $lexical = 5;
1067     my @exp = (5, 7, 9);
1068     for (0, 1, 2) {
1069         no warnings 'void';
1070         my $scalar = do { given ($_) {
1071             $lexical when 0;
1072             8, 9     when 2;
1073             6, 7;
1074         } };
1075         is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]");
1076     }
1077 }
1078 {
1079     # Default scalar
1080     my @exp = (5, 9, 9);
1081     for (0, 1, 2) {
1082         my $scalar = do { given ($_) {
1083             no warnings 'void';
1084             when (0) { 5 }
1085             default  { 8, 9 }
1086             6, 7;
1087         } };
1088         is($scalar, shift(@exp), "rvalue given - default scalar [$_]");
1089     }
1090 }
1091 {
1092     # Simple list
1093     my @things = (11 .. 13);
1094     my @exp = ('3 4 5', '11 12 13', '8 9');
1095     for (0, 1, 2) {
1096         my @list = do { given ($_) {
1097             when (0) { 3 .. 5 }
1098             when (2) { my $fake = 'void'; 8, 9 }
1099             @things;
1100         } };
1101         is("@list", shift(@exp), "rvalue given - simple list [$_]");
1102     }
1103 }
1104 {
1105     # Postfix list
1106     my @things = (12);
1107     my @exp = ('3 4 5', '6 7', '12');
1108     for (0, 1, 2) {
1109         my @list = do { given ($_) {
1110             3 .. 5  when 0;
1111             @things when 2;
1112             6, 7;
1113         } };
1114         is("@list", shift(@exp), "rvalue given - postfix list [$_]");
1115     }
1116 }
1117 {
1118     # Default list
1119     my @things = (11 .. 20); # 10 elements
1120     my @exp = ('m o o', '8 10', '8 10');
1121     for (0, 1, 2) {
1122         my @list = do { given ($_) {
1123             when (0) { "moo" =~ /(.)/g }
1124             default  { 8, scalar(@things) }
1125             6, 7;
1126         } };
1127         is("@list", shift(@exp), "rvalue given - default list [$_]");
1128     }
1129 }
1130 {
1131     # Switch control
1132     my @exp = ('6 7', '', '6 7');
1133     for (0, 1, 2, 3) {
1134         my @list = do { given ($_) {
1135             continue when $_ <= 1;
1136             break    when 1;
1137             next     when 2;
1138             6, 7;
1139         } };
1140         is("@list", shift(@exp), "rvalue given - default list [$_]");
1141     }
1142 }
1143 {
1144     # Context propagation
1145     my $smart_hash = sub {
1146         do { given ($_[0]) {
1147             'undef' when undef;
1148             when ([ 1 .. 3 ]) { 1 .. 3 }
1149             when (4) { my $fake; do { 4, 5 } }
1150         } };
1151     };
1152
1153     my $scalar;
1154
1155     $scalar = $smart_hash->();
1156     is($scalar, 'undef', "rvalue given - scalar context propagation [undef]");
1157
1158     $scalar = $smart_hash->(4);
1159     is($scalar, 5,       "rvalue given - scalar context propagation [4]");
1160
1161     $scalar = $smart_hash->(999);
1162     is($scalar, undef,   "rvalue given - scalar context propagation [999]");
1163
1164     my @list;
1165
1166     @list = $smart_hash->();
1167     is("@list", 'undef', "rvalue given - list context propagation [undef]");
1168
1169     @list = $smart_hash->(2);
1170     is("@list", '1 2 3', "rvalue given - list context propagation [2]");
1171
1172     @list = $smart_hash->(4);
1173     is("@list", '4 5',   "rvalue given - list context propagation [4]");
1174
1175     @list = $smart_hash->(999);
1176     is("@list", '',      "rvalue given - list context propagation [999]");
1177 }
1178 {
1179     # Array slices
1180     my @list = 10 .. 15;
1181     my @in_list;
1182     my @in_slice;
1183     for (5, 10, 15) {
1184         given ($_) {
1185             when (@list) {
1186                 push @in_list, $_;
1187                 continue;
1188             }
1189             when (@list[0..2]) {
1190                 push @in_slice, $_;
1191             }
1192         }
1193     }
1194     is("@in_list", "10 15", "when(array)");
1195     is("@in_slice", "10", "when(array slice)");
1196 }
1197 {
1198     # Hash slices
1199     my %list = map { $_ => $_ } "a" .. "f";
1200     my @in_list;
1201     my @in_slice;
1202     for ("a", "e", "i") {
1203         given ($_) {
1204             when (%list) {
1205                 push @in_list, $_;
1206                 continue;
1207             }
1208             when (@list{"a".."c"}) {
1209                 push @in_slice, $_;
1210             }
1211         }
1212     }
1213     is("@in_list", "a e", "when(hash)");
1214     is("@in_slice", "a", "when(hash slice)");
1215 }
1216
1217 { # RT#84526 - Handle magical TARG
1218     my $x = my $y = "aaa";
1219     for ($x, $y) {
1220         given ($_) {
1221             is(pos, undef, "handle magical TARG");
1222             pos = 1;
1223         }
1224     }
1225 }
1226
1227 # Test that returned values are correctly propagated through several context
1228 # levels (see RT #93548).
1229 {
1230     my $tester = sub {
1231         my $id = shift;
1232
1233         package fmurrr;
1234
1235         our ($when_loc, $given_loc, $ext_loc);
1236
1237         my $ext_lex    = 7;
1238         our $ext_glob  = 8;
1239         local $ext_loc = 9;
1240
1241         given ($id) {
1242             my $given_lex    = 4;
1243             our $given_glob  = 5;
1244             local $given_loc = 6;
1245
1246             when (0) { 0 }
1247
1248             when (1) { my $when_lex    = 1 }
1249             when (2) { our $when_glob  = 2 }
1250             when (3) { local $when_loc = 3 }
1251
1252             when (4) { $given_lex }
1253             when (5) { $given_glob }
1254             when (6) { $given_loc }
1255
1256             when (7) { $ext_lex }
1257             when (8) { $ext_glob }
1258             when (9) { $ext_loc }
1259
1260             'fallback';
1261         }
1262     };
1263
1264     my @descriptions = qw<
1265         constant
1266
1267         when-lexical
1268         when-global
1269         when-local
1270
1271         given-lexical
1272         given-global
1273         given-local
1274
1275         extern-lexical
1276         extern-global
1277         extern-local
1278     >;
1279
1280     for my $id (0 .. 9) {
1281         my $desc = $descriptions[$id];
1282
1283         my $res = $tester->($id);
1284         is $res, $id, "plain call - $desc";
1285
1286         $res = do {
1287             my $id_plus_1 = $id + 1;
1288             given ($id_plus_1) {
1289                 do {
1290                     when (/\d/) {
1291                         --$id_plus_1;
1292                         continue;
1293                         456;
1294                     }
1295                 };
1296                 default {
1297                     $tester->($id_plus_1);
1298                 }
1299                 'XXX';
1300             }
1301         };
1302         is $res, $id, "across continue and default - $desc";
1303     }
1304 }
1305
1306 # Check that values returned from given/when are destroyed at the right time.
1307 {
1308     {
1309         package Fmurrr;
1310
1311         sub new {
1312             bless {
1313                 flag => \($_[1]),
1314                 id   => $_[2],
1315             }, $_[0]
1316         }
1317
1318         sub DESTROY {
1319             ${$_[0]->{flag}}++;
1320         }
1321     }
1322
1323     my @descriptions = qw<
1324         when
1325         break
1326         continue
1327         default
1328     >;
1329
1330     for my $id (0 .. 3) {
1331         my $desc = $descriptions[$id];
1332
1333         my $destroyed = 0;
1334         my $res_id;
1335
1336         {
1337             my $res = do {
1338                 given ($id) {
1339                     my $x;
1340                     when (0) { Fmurrr->new($destroyed, 0) }
1341                     when (1) { my $y = Fmurrr->new($destroyed, 1); break }
1342                     when (2) { $x = Fmurrr->new($destroyed, 2); continue }
1343                     when (2) { $x }
1344                     default  { Fmurrr->new($destroyed, 3) }
1345                 }
1346             };
1347             $res_id = $res->{id};
1348         }
1349         $res_id = $id if $id == 1; # break doesn't return anything
1350
1351         is $res_id,    $id, "given/when returns the right object - $desc";
1352         is $destroyed, 1,   "given/when does not leak - $desc";
1353     };
1354 }
1355
1356 # break() must reset the stack
1357 {
1358     my @res = (1, do {
1359         given ("x") {
1360             2, 3, do {
1361                 when (/[a-z]/) {
1362                     4, 5, 6, break
1363                 }
1364             }
1365         }
1366     });
1367     is "@res", "1", "break resets the stack";
1368 }
1369
1370 # RT #94682:
1371 # must ensure $_ is initialised and cleared at start/end of given block
1372
1373 {
1374     sub f1 {
1375         no warnings 'experimental::lexical_topic';
1376         my $_;
1377         given(3) {
1378             return sub { $_ } # close over lexical $_
1379         }
1380     }
1381     is(f1()->(), 3, 'closed over $_');
1382
1383     package RT94682;
1384
1385     my $d = 0;
1386     sub DESTROY { $d++ };
1387
1388     sub f2 {
1389         no warnings 'experimental::lexical_topic';
1390         my $_ = 5;
1391         given(bless [7]) {
1392             ::is($_->[0], 7, "is [7]");
1393         }
1394         ::is($_, 5, "is 5");
1395         ::is($d, 1, "DESTROY called once");
1396     }
1397     f2();
1398 }
1399
1400
1401
1402 # Okay, that'll do for now. The intricacies of the smartmatch
1403 # semantics are tested in t/op/smartmatch.t. Taintedness of
1404 # returned values is checked in t/op/taint.t.
1405 __END__