t/op/switch.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6 }
   7
   8 use strict;
   9 use warnings;
  10
  11 use Test::More tests => 107;
  12
  13 # The behaviour of the feature pragma should be tested by lib/switch.t
  14 # using the tests in t/lib/switch/*. This file tests the behaviour of
  15 # the switch ops themselves.
  16
  17
  18 use feature 'switch';
  19 no warnings "numeric";
  20
  21 eval { continue };
  22 like($@, qr/^Can't "continue" outside/, "continue outside");
  23
  24 eval { break };
  25 like($@, qr/^Can't "break" outside/, "break outside");
  26
  27 # Scoping rules
  28
  29 {
  30     my $x = "foo";
  31     given(my $x = "bar") {
  32         is($x, "bar", "given scope starts");
  33     }
  34     is($x, "foo", "given scope ends");
  35 }
  36
  37 sub be_true {1}
  38
  39 given(my $x = "foo") {
  40     when(be_true(my $x = "bar")) {
  41         is($x, "bar", "given scope starts");
  42     }
  43     is($x, "foo", "given scope ends");
  44 }
  45
  46 $_ = "outside";
  47 given("inside") { check_outside1() }
  48 sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
  49
  50 {
  51     my $_ = "outside";
  52     given("inside") { check_outside2() }
  53     sub check_outside2 {
  54         is($_, "outside", "\$_ lexically scoped (lexical \$_)")
  55     }
  56 }
  57
  58 # Basic string/numeric comparisons and control flow
  59
  60 {
  61     my $ok = 0;
  62     given(3) {
  63         when(2) { $ok = 0; }
  64         when(3) { $ok = 1; }
  65         when(4) { $ok = 0; }
  66         default { $ok = 0; }
  67     }
  68     ok($ok, "numeric comparison");
  69 }
  70
  71 {
  72     my $ok = 0;
  73     use integer;
  74     given(3.14159265) {
  75         when(2) { $ok = 0; }
  76         when(3) { $ok = 1; }
  77         when(4) { $ok = 0; }
  78         default { $ok = 0; }
  79     }
  80     ok($ok, "integer comparison");
  81 }
  82
  83 {
  84     my ($ok1, $ok2) = (0, 0);
  85     given(3) {
  86         when(3.1)   { $ok1 = 0; }
  87         when(3.0)   { $ok1 = 1; continue }
  88         when("3.0") { $ok2 = 1; }
  89         default     { $ok2 = 0; }
  90     }
  91     ok($ok1, "more numeric (pt. 1)");
  92     ok($ok2, "more numeric (pt. 2)");
  93 }
  94
  95 {
  96     my $ok = 0;
  97     given("c") {
  98         when("b") { $ok = 0; }
  99         when("c") { $ok = 1; }
 100         when("d") { $ok = 0; }
 101         default   { $ok = 0; }
 102     }
 103     ok($ok, "string comparison");
 104 }
 105
 106 {
 107     my $ok = 0;
 108     given("c") {
 109         when("b") { $ok = 0; }
 110         when("c") { $ok = 0; continue }
 111         when("c") { $ok = 1; }
 112         default   { $ok = 0; }
 113     }
 114     ok($ok, "simple continue");
 115 }
 116
 117 # Definedness
 118 {
 119     my $ok = 1;
 120     given (0) { when(undef) {$ok = 0} }
 121     ok($ok, "Given(0) when(undef)");
 122 }
 123 {
 124     my $undef;
 125     my $ok = 1;
 126     given (0) { when($undef) {$ok = 0} }
 127     ok($ok, 'Given(0) when($undef)');
 128 }
 129 {
 130     my $undef;
 131     my $ok = 0;
 132     given (0) { when($undef++) {$ok = 1} }
 133     ok($ok, "Given(0) when($undef++)");
 134 }
 135 {
 136     my $ok = 1;
 137     given (undef) { when(0) {$ok = 0} }
 138     ok($ok, "Given(undef) when(0)");
 139 }
 140 {
 141     my $undef;
 142     my $ok = 1;
 143     given ($undef) { when(0) {$ok = 0} }
 144     ok($ok, 'Given($undef) when(0)');
 145 }
 146 ########
 147 {
 148     my $ok = 1;
 149     given ("") { when(undef) {$ok = 0} }
 150     ok($ok, 'Given("") when(undef)');
 151 }
 152 {
 153     my $undef;
 154     my $ok = 1;
 155     given ("") { when($undef) {$ok = 0} }
 156     ok($ok, 'Given("") when($undef)');
 157 }
 158 {
 159     my $ok = 1;
 160     given (undef) { when("") {$ok = 0} }
 161     ok($ok, 'Given(undef) when("")');
 162 }
 163 {
 164     my $undef;
 165     my $ok = 1;
 166     given ($undef) { when("") {$ok = 0} }
 167     ok($ok, 'Given($undef) when("")');
 168 }
 169 ########
 170 {
 171     my $ok = 0;
 172     given (undef) { when(undef) {$ok = 1} }
 173     ok($ok, "Given(undef) when(undef)");
 174 }
 175 {
 176     my $undef;
 177     my $ok = 0;
 178     given (undef) { when($undef) {$ok = 1} }
 179     ok($ok, 'Given(undef) when($undef)');
 180 }
 181 {
 182     my $undef;
 183     my $ok = 0;
 184     given ($undef) { when(undef) {$ok = 1} }
 185     ok($ok, 'Given($undef) when(undef)');
 186 }
 187 {
 188     my $undef;
 189     my $ok = 0;
 190     given ($undef) { when($undef) {$ok = 1} }
 191     ok($ok, 'Given($undef) when($undef)');
 192 }
 193
 194
 195 # Regular expressions
 196 {
 197     my ($ok1, $ok2) = 0;
 198     given("Hello, world!") {
 199         when(/lo/)
 200             { $ok1 = 1; continue}
 201         when(/no/)
 202             { $ok1 = 0; continue}
 203         when(/^(Hello,|Goodbye cruel) world[!.?]/)
 204             { $ok2 = 1; continue}
 205         when(/^(Hello cruel|Goodbye,) world[!.?]/)
 206             { $ok2 = 0; continue}
 207     }
 208     ok($ok1, "regex 1");
 209     ok($ok2, "regex 2");
 210 }
 211
 212 # Comparisons
 213 {
 214     my $test = "explicit numeric comparison (<)";
 215     my $twenty_five = 25;
 216     given($twenty_five) {
 217         when ($_ < 10) { fail($test) }
 218         when ($_ < 20) { fail($test) }
 219         when ($_ < 30) { pass($test) }
 220         when ($_ < 40) { fail($test) }
 221         default        { fail($test) }
 222     }
 223 }
 224
 225 {
 226     use integer;
 227     my $test = "explicit numeric comparison (integer <)";
 228     my $twenty_five = 25;
 229     given($twenty_five) {
 230         when ($_ < 10) { fail($test) }
 231         when ($_ < 20) { fail($test) }
 232         when ($_ < 30) { pass($test) }
 233         when ($_ < 40) { fail($test) }
 234         default        { fail($test) }
 235     }
 236 }
 237
 238 {
 239     my $test = "explicit numeric comparison (<=)";
 240     my $twenty_five = 25;
 241     given($twenty_five) {
 242         when ($_ <= 10) { fail($test) }
 243         when ($_ <= 20) { fail($test) }
 244         when ($_ <= 30) { pass($test) }
 245         when ($_ <= 40) { fail($test) }
 246         default         { fail($test) }
 247     }
 248 }
 249
 250 {
 251     use integer;
 252     my $test = "explicit numeric comparison (integer <=)";
 253     my $twenty_five = 25;
 254     given($twenty_five) {
 255         when ($_ <= 10) { fail($test) }
 256         when ($_ <= 20) { fail($test) }
 257         when ($_ <= 30) { pass($test) }
 258         when ($_ <= 40) { fail($test) }
 259         default         { fail($test) }
 260     }
 261 }
 262
 263
 264 {
 265     my $test = "explicit numeric comparison (>)";
 266     my $twenty_five = 25;
 267     given($twenty_five) {
 268         when ($_ > 40) { fail($test) }
 269         when ($_ > 30) { fail($test) }
 270         when ($_ > 20) { pass($test) }
 271         when ($_ > 10) { fail($test) }
 272         default        { fail($test) }
 273     }
 274 }
 275
 276 {
 277     my $test = "explicit numeric comparison (>=)";
 278     my $twenty_five = 25;
 279     given($twenty_five) {
 280         when ($_ >= 40) { fail($test) }
 281         when ($_ >= 30) { fail($test) }
 282         when ($_ >= 20) { pass($test) }
 283         when ($_ >= 10) { fail($test) }
 284         default         { fail($test) }
 285     }
 286 }
 287
 288 {
 289     use integer;
 290     my $test = "explicit numeric comparison (integer >)";
 291     my $twenty_five = 25;
 292     given($twenty_five) {
 293         when ($_ > 40) { fail($test) }
 294         when ($_ > 30) { fail($test) }
 295         when ($_ > 20) { pass($test) }
 296         when ($_ > 10) { fail($test) }
 297         default        { fail($test) }
 298     }
 299 }
 300
 301 {
 302     use integer;
 303     my $test = "explicit numeric comparison (integer >=)";
 304     my $twenty_five = 25;
 305     given($twenty_five) {
 306         when ($_ >= 40) { fail($test) }
 307         when ($_ >= 30) { fail($test) }
 308         when ($_ >= 20) { pass($test) }
 309         when ($_ >= 10) { fail($test) }
 310         default         { fail($test) }
 311     }
 312 }
 313
 314
 315 {
 316     my $test = "explicit string comparison (lt)";
 317     my $twenty_five = "25";
 318     given($twenty_five) {
 319         when ($_ lt "10") { fail($test) }
 320         when ($_ lt "20") { fail($test) }
 321         when ($_ lt "30") { pass($test) }
 322         when ($_ lt "40") { fail($test) }
 323         default         { fail($test) }
 324     }
 325 }
 326
 327 {
 328     my $test = "explicit string comparison (le)";
 329     my $twenty_five = "25";
 330     given($twenty_five) {
 331         when ($_ le "10") { fail($test) }
 332         when ($_ le "20") { fail($test) }
 333         when ($_ le "30") { pass($test) }
 334         when ($_ le "40") { fail($test) }
 335         default           { fail($test) }
 336     }
 337 }
 338
 339 {
 340     my $test = "explicit string comparison (gt)";
 341     my $twenty_five = 25;
 342     given($twenty_five) {
 343         when ($_ ge "40") { fail($test) }
 344         when ($_ ge "30") { fail($test) }
 345         when ($_ ge "20") { pass($test) }
 346         when ($_ ge "10") { fail($test) }
 347         default           { fail($test) }
 348     }
 349 }
 350
 351 {
 352     my $test = "explicit string comparison (ge)";
 353     my $twenty_five = 25;
 354     given($twenty_five) {
 355         when ($_ ge "40") { fail($test) }
 356         when ($_ ge "30") { fail($test) }
 357         when ($_ ge "20") { pass($test) }
 358         when ($_ ge "10") { fail($test) }
 359         default           { fail($test) }
 360     }
 361 }
 362
 363 # Make sure it still works with a lexical $_:
 364 {
 365     my $_;
 366     my $test = "explicit comparison with lexical \$_";
 367     my $twenty_five = 25;
 368     given($twenty_five) {
 369         when ($_ ge "40") { fail($test) }
 370         when ($_ ge "30") { fail($test) }
 371         when ($_ ge "20") { pass($test) }
 372         when ($_ ge "10") { fail($test) }
 373         default           { fail($test) }
 374     }
 375 }
 376
 377 # Optimized-away comparisons
 378 {
 379     my $ok = 0;
 380     given(23) {
 381         when (2 + 2 == 4) { $ok = 1; continue }
 382         when (2 + 2 == 5) { $ok = 0 }
 383     }
 384     ok($ok, "Optimized-away comparison");
 385 }
 386
 387 # File tests
 388 #  (How to be both thorough and portable? Pinch a few ideas
 389 #  from t/op/filetest.t. We err on the side of portability for
 390 #  the time being.)
 391
 392 {
 393     my ($ok_d, $ok_f, $ok_r);
 394     given("op") {
 395         when(-d)  {$ok_d = 1; continue}
 396         when(!-f) {$ok_f = 1; continue}
 397         when(-r)  {$ok_r = 1; continue}
 398     }
 399     ok($ok_d, "Filetest -d");
 400     ok($ok_f, "Filetest -f");
 401     ok($ok_r, "Filetest -r");
 402 }
 403
 404 # Sub and method calls
 405 sub bar {"bar"}
 406 {
 407     my $ok = 0;
 408     given("foo") {
 409         when(bar()) {$ok = 1}
 410     }
 411     ok($ok, "Sub call acts as boolean")
 412 }
 413
 414 {
 415     my $ok = 0;
 416     given("foo") {
 417         when(main->bar()) {$ok = 1}
 418     }
 419     ok($ok, "Class-method call acts as boolean")
 420 }
 421
 422 {
 423     my $ok = 0;
 424     my $obj = bless [];
 425     given("foo") {
 426         when($obj->bar()) {$ok = 1}
 427     }
 428     ok($ok, "Object-method call acts as boolean")
 429 }
 430
 431 # Other things that should not be smart matched
 432 {
 433     my $ok = 0;
 434     given(0) {
 435         when(eof(DATA)) {
 436             $ok = 1;
 437         }
 438     }
 439     ok($ok, "eof() not smartmatched");
 440 }
 441
 442 {
 443     my $ok = 0;
 444     my %foo = ("bar", 0);
 445     given(0) {
 446         when(exists $foo{bar}) {
 447             $ok = 1;
 448         }
 449     }
 450     ok($ok, "exists() not smartmatched");
 451 }
 452
 453 {
 454     my $ok = 0;
 455     given(0) {
 456         when(defined $ok) {
 457             $ok = 1;
 458         }
 459     }
 460     ok($ok, "defined() not smartmatched");
 461 }
 462
 463 {
 464     my $ok = 1;
 465     given("foo") {
 466         when((1 == 1) && "bar") {
 467             $ok = 0;
 468         }
 469         when((1 == 1) && $_ eq "foo") {
 470             $ok = 2;
 471         }
 472     }
 473     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
 474 }
 475
 476 {
 477     my $ok = 1;
 478     given(0) {
 479         when((1 == $ok) || "foo") {
 480             $ok = 0;
 481         }
 482     }
 483     ok($ok, '((1 == $ok) || "foo") not smartmatched');
 484 }
 485
 486
 487 # Make sure we aren't invoking the get-magic more than once
 488
 489 { # A helper class to count the number of accesses.
 490     package FetchCounter;
 491     sub TIESCALAR {
 492         my ($class) = @_;
 493         bless {value => undef, count => 0}, $class;
 494     }
 495     sub STORE {
 496         my ($self, $val) = @_;
 497         $self->{count} = 0;
 498         $self->{value} = $val;
 499     }
 500     sub FETCH {
 501         my ($self) = @_;
 502         # Avoid pre/post increment here
 503         $self->{count} = 1 + $self->{count};
 504         $self->{value};
 505     }
 506     sub count {
 507         my ($self) = @_;
 508         $self->{count};
 509     }
 510 }
 511
 512 my $f = tie my $v, "FetchCounter";
 513
 514 {   my $test_name = "Only one FETCH (in given)";
 515     my $ok = 0;
 516     given($v = 23) {
 517         when(undef) {}
 518         when(sub{0}->()) {}
 519         when(21) {}
 520         when("22") {}
 521         when(23) {$ok = 1}
 522         when(/24/) {$ok = 0}
 523     }
 524     ok($ok, "precheck: $test_name");
 525     is($f->count(), 1, $test_name);
 526 }
 527
 528 {   my $test_name = "Only one FETCH (numeric when)";
 529     my $ok = 0;
 530     $v = 23;
 531     is($f->count(), 0, "Sanity check: $test_name");
 532     given(23) {
 533         when(undef) {}
 534         when(sub{0}->()) {}
 535         when(21) {}
 536         when("22") {}
 537         when($v) {$ok = 1}
 538         when(/24/) {$ok = 0}
 539     }
 540     ok($ok, "precheck: $test_name");
 541     is($f->count(), 1, $test_name);
 542 }
 543
 544 {   my $test_name = "Only one FETCH (string when)";
 545     my $ok = 0;
 546     $v = "23";
 547     is($f->count(), 0, "Sanity check: $test_name");
 548     given("23") {
 549         when(undef) {}
 550         when(sub{0}->()) {}
 551         when("21") {}
 552         when("22") {}
 553         when($v) {$ok = 1}
 554         when(/24/) {$ok = 0}
 555     }
 556     ok($ok, "precheck: $test_name");
 557     is($f->count(), 1, $test_name);
 558 }
 559
 560 {   my $test_name = "Only one FETCH (undef)";
 561     my $ok = 0;
 562     $v = undef;
 563     is($f->count(), 0, "Sanity check: $test_name");
 564     given(my $undef) {
 565         when(sub{0}->()) {}
 566         when("21")  {}
 567         when("22")  {}
 568         when($v)    {$ok = 1}
 569         when(undef) {$ok = 0}
 570     }
 571     ok($ok, "precheck: $test_name");
 572     is($f->count(), 1, $test_name);
 573 }
 574
 575 # Loop topicalizer
 576 {
 577     my $first = 1;
 578     for (1, "two") {
 579         when ("two") {
 580             is($first, 0, "Loop: second");
 581             eval {break};
 582             like($@, qr/^Can't "break" in a loop topicalizer/,
 583                 q{Can't "break" in a loop topicalizer});
 584         }
 585         when (1) {
 586             is($first, 1, "Loop: first");
 587             $first = 0;
 588             # Implicit break is okay
 589         }
 590     }
 591 }
 592
 593 {
 594     my $first = 1;
 595     for $_ (1, "two") {
 596         when ("two") {
 597             is($first, 0, "Explicit \$_: second");
 598             eval {break};
 599             like($@, qr/^Can't "break" in a loop topicalizer/,
 600                 q{Can't "break" in a loop topicalizer});
 601         }
 602         when (1) {
 603             is($first, 1, "Explicit \$_: first");
 604             $first = 0;
 605             # Implicit break is okay
 606         }
 607     }
 608 }
 609
 610 {
 611     my $first = 1;
 612     my $_;
 613     for (1, "two") {
 614         when ("two") {
 615             is($first, 0, "Implicitly lexical loop: second");
 616             eval {break};
 617             like($@, qr/^Can't "break" in a loop topicalizer/,
 618                 q{Can't "break" in a loop topicalizer});
 619         }
 620         when (1) {
 621             is($first, 1, "Implicitly lexical loop: first");
 622             $first = 0;
 623             # Implicit break is okay
 624         }
 625     }
 626 }
 627
 628 {
 629     my $first = 1;
 630     my $_;
 631     for $_ (1, "two") {
 632         when ("two") {
 633             is($first, 0, "Implicitly lexical, explicit \$_: second");
 634             eval {break};
 635             like($@, qr/^Can't "break" in a loop topicalizer/,
 636                 q{Can't "break" in a loop topicalizer});
 637         }
 638         when (1) {
 639             is($first, 1, "Implicitly lexical, explicit \$_: first");
 640             $first = 0;
 641             # Implicit break is okay
 642         }
 643     }
 644 }
 645
 646 {
 647     my $first = 1;
 648     for my $_ (1, "two") {
 649         when ("two") {
 650             is($first, 0, "Lexical loop: second");
 651             eval {break};
 652             like($@, qr/^Can't "break" in a loop topicalizer/,
 653                 q{Can't "break" in a loop topicalizer});
 654         }
 655         when (1) {
 656             is($first, 1, "Lecical loop: first");
 657             $first = 0;
 658             # Implicit break is okay
 659         }
 660     }
 661 }
 662
 663
 664 # Code references
 665 {
 666     no warnings "redefine";
 667     my $called_foo = 0;
 668     sub foo {$called_foo = 1}
 669     my $called_bar = 0;
 670     sub bar {$called_bar = 1}
 671     my ($matched_foo, $matched_bar) = (0, 0);
 672     given(\&foo) {
 673         when(\&bar) {$matched_bar = 1}
 674         when(\&foo) {$matched_foo = 1}
 675     }
 676     is($called_foo, 0,  "Code ref comparison: foo not called");
 677     is($called_bar, 0,  "Code ref comparison: bar not called");
 678     is($matched_bar, 0, "Code ref didn't match different one");
 679     is($matched_foo, 1, "Code ref did match itself");
 680 }
 681
 682 sub contains_x {
 683     my $x = shift;
 684     return ($x =~ /x/);
 685 }
 686 {
 687     my ($ok1, $ok2) = (0,0);
 688     given("foxy!") {
 689         when(contains_x($_))
 690             { $ok1 = 1; continue }
 691         when(\&contains_x)
 692             { $ok2 = 1; continue }
 693     }
 694     is($ok1, 1, "Calling sub directly (true)");
 695     is($ok2, 1, "Calling sub indirectly (true)");
 696
 697     given("foggy") {
 698         when(contains_x($_))
 699             { $ok1 = 2; continue }
 700         when(\&contains_x)
 701             { $ok2 = 2; continue }
 702     }
 703     is($ok1, 1, "Calling sub directly (false)");
 704     is($ok2, 1, "Calling sub indirectly (false)");
 705 }
 706
 707 # Test overloading
 708 { package OverloadTest;
 709
 710     use overload '""' => sub{"string value of obj"};
 711
 712     use overload "~~" => sub {
 713         my ($self, $other, $reversed) = @_;
 714         if ($reversed) {
 715             $self->{left}  = $other;
 716             $self->{right} = $self;
 717             $self->{reversed} = 1;
 718         } else {
 719             $self->{left}  = $self;
 720             $self->{right} = $other;
 721             $self->{reversed} = 0;
 722         }
 723         $self->{called} = 1;
 724         return $self->{retval};
 725     };
 726
 727     sub new {
 728         my ($pkg, $retval) = @_;
 729         bless {
 730             called => 0,
 731             retval => $retval,
 732         }, $pkg;
 733     }
 734 }
 735
 736 {
 737     my $test = "Overloaded obj in given (true)";
 738     my $obj = OverloadTest->new(1);
 739     my $matched;
 740     given($obj) {
 741         when ("other arg") {$matched = 1}
 742         default {$matched = 0}
 743     }
 744
 745     is($obj->{called},  1, "$test: called");
 746     ok($matched, "$test: matched");
 747     is($obj->{left}, "string value of obj", "$test: left");
 748     is($obj->{right}, "other arg", "$test: right");
 749     ok(!$obj->{reversed}, "$test: not reversed");
 750 }
 751
 752 {
 753     my $test = "Overloaded obj in given (false)";
 754     my $obj = OverloadTest->new(0);
 755     my $matched;
 756     given($obj) {
 757         when ("other arg") {$matched = 1}
 758     }
 759
 760     is($obj->{called},  1, "$test: called");
 761     ok(!$matched, "$test: not matched");
 762     is($obj->{left}, "string value of obj", "$test: left");
 763     is($obj->{right}, "other arg", "$test: right");
 764     ok(!$obj->{reversed}, "$test: not reversed");
 765 }
 766
 767 {
 768     my $test = "Overloaded obj in when (true)";
 769     my $obj = OverloadTest->new(1);
 770     my $matched;
 771     given("topic") {
 772         when ($obj) {$matched = 1}
 773         default {$matched = 0}
 774     }
 775
 776     is($obj->{called},  1, "$test: called");
 777     ok($matched, "$test: matched");
 778     is($obj->{left}, "topic", "$test: left");
 779     is($obj->{right}, "string value of obj", "$test: right");
 780     ok($obj->{reversed}, "$test: reversed");
 781 }
 782
 783 {
 784     my $test = "Overloaded obj in when (false)";
 785     my $obj = OverloadTest->new(0);
 786     my $matched;
 787     given("topic") {
 788         when ($obj) {$matched = 1}
 789         default {$matched = 0}
 790     }
 791
 792     is($obj->{called}, 1, "$test: called");
 793     ok(!$matched, "$test: not matched");
 794     is($obj->{left}, "topic", "$test: left");
 795     is($obj->{right}, "string value of obj", "$test: right");
 796     ok($obj->{reversed}, "$test: reversed");
 797 }
 798
 799 # Okay, that'll do for now. The intricacies of the smartmatch
 800 # semantics are tested in t/op/smartmatch.t
 801 __END__