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