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 => 118;
  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;
  62     given(3) {
  63         when(2) { $ok = 'two'; }
  64         when(3) { $ok = 'three'; }
  65         when(4) { $ok = 'four'; }
  66         default { $ok = 'd'; }
  67     }
  68     is($ok, 'three', "numeric comparison");
  69 }
  70
  71 {
  72     my $ok;
  73     use integer;
  74     given(3.14159265) {
  75         when(2) { $ok = 'two'; }
  76         when(3) { $ok = 'three'; }
  77         when(4) { $ok = 'four'; }
  78         default { $ok = 'd'; }
  79     }
  80     is($ok, 'three', "integer comparison");
  81 }
  82
  83 {
  84     my ($ok1, $ok2);
  85     given(3) {
  86         when(3.1)   { $ok1 = 'n'; }
  87         when(3.0)   { $ok1 = 'y'; continue }
  88         when("3.0") { $ok2 = 'y'; }
  89         default     { $ok2 = 'n'; }
  90     }
  91     is($ok1, 'y', "more numeric (pt. 1)");
  92     is($ok2, 'y', "more numeric (pt. 2)");
  93 }
  94
  95 {
  96     my $ok;
  97     given("c") {
  98         when("b") { $ok = 'B'; }
  99         when("c") { $ok = 'C'; }
 100         when("d") { $ok = 'D'; }
 101         default   { $ok = 'def'; }
 102     }
 103     is($ok, 'C', "string comparison");
 104 }
 105
 106 {
 107     my $ok;
 108     given("c") {
 109         when("b") { $ok = 'B'; }
 110         when("c") { $ok = 'C'; continue }
 111         when("c") { $ok = 'CC'; }
 112         default   { $ok = 'D'; }
 113     }
 114     is($ok, 'CC', "simple continue");
 115 }
 116
 117 # Definedness
 118 {
 119     my $ok = 1;
 120     given (0) { when(undef) {$ok = 0} }
 121     is($ok, 1, "Given(0) when(undef)");
 122 }
 123 {
 124     my $undef;
 125     my $ok = 1;
 126     given (0) { when($undef) {$ok = 0} }
 127     is($ok, 1, 'Given(0) when($undef)');
 128 }
 129 {
 130     my $undef;
 131     my $ok = 0;
 132     given (0) { when($undef++) {$ok = 1} }
 133     is($ok, 1, "Given(0) when($undef++)");
 134 }
 135 {
 136     no warnings "uninitialized";
 137     my $ok = 0;
 138     given (undef) { when(0) {$ok = 1} }
 139     is($ok, 1, "Given(undef) when(0)");
 140 }
 141 {
 142     no warnings "uninitialized";
 143     my $undef;
 144     my $ok = 0;
 145     given ($undef) { when(0) {$ok = 1} }
 146     is($ok, 1, 'Given($undef) when(0)');
 147 }
 148 ########
 149 {
 150     my $ok = 1;
 151     given ("") { when(undef) {$ok = 0} }
 152     is($ok, 1, 'Given("") when(undef)');
 153 }
 154 {
 155     my $undef;
 156     my $ok = 1;
 157     given ("") { when($undef) {$ok = 0} }
 158     is($ok, 1, 'Given("") when($undef)');
 159 }
 160 {
 161     no warnings "uninitialized";
 162     my $ok = 0;
 163     given (undef) { when("") {$ok = 1} }
 164     is($ok, 1, 'Given(undef) when("")');
 165 }
 166 {
 167     no warnings "uninitialized";
 168     my $undef;
 169     my $ok = 0;
 170     given ($undef) { when("") {$ok = 1} }
 171     is($ok, 1, 'Given($undef) when("")');
 172 }
 173 ########
 174 {
 175     my $ok = 0;
 176     given (undef) { when(undef) {$ok = 1} }
 177     is($ok, 1, "Given(undef) when(undef)");
 178 }
 179 {
 180     my $undef;
 181     my $ok = 0;
 182     given (undef) { when($undef) {$ok = 1} }
 183     is($ok, 1, 'Given(undef) when($undef)');
 184 }
 185 {
 186     my $undef;
 187     my $ok = 0;
 188     given ($undef) { when(undef) {$ok = 1} }
 189     is($ok, 1, 'Given($undef) when(undef)');
 190 }
 191 {
 192     my $undef;
 193     my $ok = 0;
 194     given ($undef) { when($undef) {$ok = 1} }
 195     is($ok, 1, 'Given($undef) when($undef)');
 196 }
 197
 198
 199 # Regular expressions
 200 {
 201     my ($ok1, $ok2);
 202     given("Hello, world!") {
 203         when(/lo/)
 204             { $ok1 = 'y'; continue}
 205         when(/no/)
 206             { $ok1 = 'n'; continue}
 207         when(/^(Hello,|Goodbye cruel) world[!.?]/)
 208             { $ok2 = 'Y'; continue}
 209         when(/^(Hello cruel|Goodbye,) world[!.?]/)
 210             { $ok2 = 'n'; continue}
 211     }
 212     is($ok1, 'y', "regex 1");
 213     is($ok2, 'Y', "regex 2");
 214 }
 215
 216 # Comparisons
 217 {
 218     my $test = "explicit numeric comparison (<)";
 219     my $twenty_five = 25;
 220     my $ok;
 221     given($twenty_five) {
 222         when ($_ < 10) { $ok = "ten" }
 223         when ($_ < 20) { $ok = "twenty" }
 224         when ($_ < 30) { $ok = "thirty" }
 225         when ($_ < 40) { $ok = "forty" }
 226         default        { $ok = "default" }
 227     }
 228     is($ok, "thirty", $test);
 229 }
 230
 231 {
 232     use integer;
 233     my $test = "explicit numeric comparison (integer <)";
 234     my $twenty_five = 25;
 235     my $ok;
 236     given($twenty_five) {
 237         when ($_ < 10) { $ok = "ten" }
 238         when ($_ < 20) { $ok = "twenty" }
 239         when ($_ < 30) { $ok = "thirty" }
 240         when ($_ < 40) { $ok = "forty" }
 241         default        { $ok = "default" }
 242     }
 243     is($ok, "thirty", $test);
 244 }
 245
 246 {
 247     my $test = "explicit numeric comparison (<=)";
 248     my $twenty_five = 25;
 249     my $ok;
 250     given($twenty_five) {
 251         when ($_ <= 10) { $ok = "ten" }
 252         when ($_ <= 20) { $ok = "twenty" }
 253         when ($_ <= 30) { $ok = "thirty" }
 254         when ($_ <= 40) { $ok = "forty" }
 255         default         { $ok = "default" }
 256     }
 257     is($ok, "thirty", $test);
 258 }
 259
 260 {
 261     use integer;
 262     my $test = "explicit numeric comparison (integer <=)";
 263     my $twenty_five = 25;
 264     my $ok;
 265     given($twenty_five) {
 266         when ($_ <= 10) { $ok = "ten" }
 267         when ($_ <= 20) { $ok = "twenty" }
 268         when ($_ <= 30) { $ok = "thirty" }
 269         when ($_ <= 40) { $ok = "forty" }
 270         default         { $ok = "default" }
 271     }
 272     is($ok, "thirty", $test);
 273 }
 274
 275
 276 {
 277     my $test = "explicit numeric comparison (>)";
 278     my $twenty_five = 25;
 279     my $ok;
 280     given($twenty_five) {
 281         when ($_ > 40) { $ok = "forty" }
 282         when ($_ > 30) { $ok = "thirty" }
 283         when ($_ > 20) { $ok = "twenty" }
 284         when ($_ > 10) { $ok = "ten" }
 285         default        { $ok = "default" }
 286     }
 287     is($ok, "twenty", $test);
 288 }
 289
 290 {
 291     my $test = "explicit numeric comparison (>=)";
 292     my $twenty_five = 25;
 293     my $ok;
 294     given($twenty_five) {
 295         when ($_ >= 40) { $ok = "forty" }
 296         when ($_ >= 30) { $ok = "thirty" }
 297         when ($_ >= 20) { $ok = "twenty" }
 298         when ($_ >= 10) { $ok = "ten" }
 299         default         { $ok = "default" }
 300     }
 301     is($ok, "twenty", $test);
 302 }
 303
 304 {
 305     use integer;
 306     my $test = "explicit numeric comparison (integer >)";
 307     my $twenty_five = 25;
 308     my $ok;
 309     given($twenty_five) {
 310         when ($_ > 40) { $ok = "forty" }
 311         when ($_ > 30) { $ok = "thirty" }
 312         when ($_ > 20) { $ok = "twenty" }
 313         when ($_ > 10) { $ok = "ten" }
 314         default        { $ok = "default" }
 315     }
 316     is($ok, "twenty", $test);
 317 }
 318
 319 {
 320     use integer;
 321     my $test = "explicit numeric comparison (integer >=)";
 322     my $twenty_five = 25;
 323     my $ok;
 324     given($twenty_five) {
 325         when ($_ >= 40) { $ok = "forty" }
 326         when ($_ >= 30) { $ok = "thirty" }
 327         when ($_ >= 20) { $ok = "twenty" }
 328         when ($_ >= 10) { $ok = "ten" }
 329         default         { $ok = "default" }
 330     }
 331     is($ok, "twenty", $test);
 332 }
 333
 334
 335 {
 336     my $test = "explicit string comparison (lt)";
 337     my $twenty_five = "25";
 338     my $ok;
 339     given($twenty_five) {
 340         when ($_ lt "10") { $ok = "ten" }
 341         when ($_ lt "20") { $ok = "twenty" }
 342         when ($_ lt "30") { $ok = "thirty" }
 343         when ($_ lt "40") { $ok = "forty" }
 344         default           { $ok = "default" }
 345     }
 346     is($ok, "thirty", $test);
 347 }
 348
 349 {
 350     my $test = "explicit string comparison (le)";
 351     my $twenty_five = "25";
 352     my $ok;
 353     given($twenty_five) {
 354         when ($_ le "10") { $ok = "ten" }
 355         when ($_ le "20") { $ok = "twenty" }
 356         when ($_ le "30") { $ok = "thirty" }
 357         when ($_ le "40") { $ok = "forty" }
 358         default           { $ok = "default" }
 359     }
 360     is($ok, "thirty", $test);
 361 }
 362
 363 {
 364     my $test = "explicit string comparison (gt)";
 365     my $twenty_five = 25;
 366     my $ok;
 367     given($twenty_five) {
 368         when ($_ ge "40") { $ok = "forty" }
 369         when ($_ ge "30") { $ok = "thirty" }
 370         when ($_ ge "20") { $ok = "twenty" }
 371         when ($_ ge "10") { $ok = "ten" }
 372         default           { $ok = "default" }
 373     }
 374     is($ok, "twenty", $test);
 375 }
 376
 377 {
 378     my $test = "explicit string comparison (ge)";
 379     my $twenty_five = 25;
 380     my $ok;
 381     given($twenty_five) {
 382         when ($_ ge "40") { $ok = "forty" }
 383         when ($_ ge "30") { $ok = "thirty" }
 384         when ($_ ge "20") { $ok = "twenty" }
 385         when ($_ ge "10") { $ok = "ten" }
 386         default           { $ok = "default" }
 387     }
 388     is($ok, "twenty", $test);
 389 }
 390
 391 # Make sure it still works with a lexical $_:
 392 {
 393     my $_;
 394     my $test = "explicit comparison with lexical \$_";
 395     my $twenty_five = 25;
 396     my $ok;
 397     given($twenty_five) {
 398         when ($_ ge "40") { $ok = "forty" }
 399         when ($_ ge "30") { $ok = "thirty" }
 400         when ($_ ge "20") { $ok = "twenty" }
 401         when ($_ ge "10") { $ok = "ten" }
 402         default           { $ok = "default" }
 403     }
 404     is($ok, "twenty", $test);
 405 }
 406
 407 # Optimized-away comparisons
 408 {
 409     my $ok;
 410     given(23) {
 411         when (2 + 2 == 4) { $ok = 'y'; continue }
 412         when (2 + 2 == 5) { $ok = 'n' }
 413     }
 414     is($ok, 'y', "Optimized-away comparison");
 415 }
 416
 417 # File tests
 418 #  (How to be both thorough and portable? Pinch a few ideas
 419 #  from t/op/filetest.t. We err on the side of portability for
 420 #  the time being.)
 421
 422 {
 423     my ($ok_d, $ok_f, $ok_r);
 424     given("op") {
 425         when(-d)  {$ok_d = 1; continue}
 426         when(!-f) {$ok_f = 1; continue}
 427         when(-r)  {$ok_r = 1; continue}
 428     }
 429     ok($ok_d, "Filetest -d");
 430     ok($ok_f, "Filetest -f");
 431     ok($ok_r, "Filetest -r");
 432 }
 433
 434 # Sub and method calls
 435 sub notfoo {"bar"}
 436 {
 437     my $ok = 0;
 438     given("foo") {
 439         when(notfoo()) {$ok = 1}
 440     }
 441     ok($ok, "Sub call acts as boolean")
 442 }
 443
 444 {
 445     my $ok = 0;
 446     given("foo") {
 447         when(main->notfoo()) {$ok = 1}
 448     }
 449     ok($ok, "Class-method call acts as boolean")
 450 }
 451
 452 {
 453     my $ok = 0;
 454     my $obj = bless [];
 455     given("foo") {
 456         when($obj->notfoo()) {$ok = 1}
 457     }
 458     ok($ok, "Object-method call acts as boolean")
 459 }
 460
 461 # Other things that should not be smart matched
 462 {
 463     my $ok = 0;
 464     given(12) {
 465         when( /(\d+)/ and ( 1 <= $1 and $1 <= 12 ) ) {
 466             $ok = 1;
 467         }
 468     }
 469     ok($ok, "bool not smartmatches");
 470 }
 471
 472 {
 473     my $ok = 0;
 474     given(0) {
 475         when(eof(DATA)) {
 476             $ok = 1;
 477         }
 478     }
 479     ok($ok, "eof() not smartmatched");
 480 }
 481
 482 {
 483     my $ok = 0;
 484     my %foo = ("bar", 0);
 485     given(0) {
 486         when(exists $foo{bar}) {
 487             $ok = 1;
 488         }
 489     }
 490     ok($ok, "exists() not smartmatched");
 491 }
 492
 493 {
 494     my $ok = 0;
 495     given(0) {
 496         when(defined $ok) {
 497             $ok = 1;
 498         }
 499     }
 500     ok($ok, "defined() not smartmatched");
 501 }
 502
 503 {
 504     my $ok = 1;
 505     given("foo") {
 506         when((1 == 1) && "bar") {
 507             $ok = 0;
 508         }
 509         when((1 == 1) && $_ eq "foo") {
 510             $ok = 2;
 511         }
 512     }
 513     is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
 514 }
 515
 516 {
 517     my $n = 0;
 518     for my $l qw(a b c d) {
 519         given ($l) {
 520             when ($_ eq "b" ... $_ eq "c") { $n = 1 }
 521             default { $n = 0 }
 522         }
 523         ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
 524     }
 525 }
 526
 527 {
 528     my $ok = 0;
 529     given("foo") {
 530         when((1 == $ok) || "foo") {
 531             $ok = 1;
 532         }
 533     }
 534     ok($ok, '((1 == $ok) || "foo") smartmatched');
 535 }
 536
 537 {
 538     my $ok = 0;
 539     given("foo") {
 540         when((1 == $ok || undef) // "foo") {
 541             $ok = 1;
 542         }
 543     }
 544     ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 545 }
 546
 547 # Make sure we aren't invoking the get-magic more than once
 548
 549 { # A helper class to count the number of accesses.
 550     package FetchCounter;
 551     sub TIESCALAR {
 552         my ($class) = @_;
 553         bless {value => undef, count => 0}, $class;
 554     }
 555     sub STORE {
 556         my ($self, $val) = @_;
 557         $self->{count} = 0;
 558         $self->{value} = $val;
 559     }
 560     sub FETCH {
 561         my ($self) = @_;
 562         # Avoid pre/post increment here
 563         $self->{count} = 1 + $self->{count};
 564         $self->{value};
 565     }
 566     sub count {
 567         my ($self) = @_;
 568         $self->{count};
 569     }
 570 }
 571
 572 my $f = tie my $v, "FetchCounter";
 573
 574 {   my $test_name = "Only one FETCH (in given)";
 575     my $ok;
 576     given($v = 23) {
 577         when(undef) {}
 578         when(sub{0}->()) {}
 579         when(21) {}
 580         when("22") {}
 581         when(23) {$ok = 1}
 582         when(/24/) {$ok = 0}
 583     }
 584     is($ok, 1, "precheck: $test_name");
 585     is($f->count(), 1, $test_name);
 586 }
 587
 588 {   my $test_name = "Only one FETCH (numeric when)";
 589     my $ok;
 590     $v = 23;
 591     is($f->count(), 0, "Sanity check: $test_name");
 592     given(23) {
 593         when(undef) {}
 594         when(sub{0}->()) {}
 595         when(21) {}
 596         when("22") {}
 597         when($v) {$ok = 1}
 598         when(/24/) {$ok = 0}
 599     }
 600     is($ok, 1, "precheck: $test_name");
 601     is($f->count(), 1, $test_name);
 602 }
 603
 604 {   my $test_name = "Only one FETCH (string when)";
 605     my $ok;
 606     $v = "23";
 607     is($f->count(), 0, "Sanity check: $test_name");
 608     given("23") {
 609         when(undef) {}
 610         when(sub{0}->()) {}
 611         when("21") {}
 612         when("22") {}
 613         when($v) {$ok = 1}
 614         when(/24/) {$ok = 0}
 615     }
 616     is($ok, 1, "precheck: $test_name");
 617     is($f->count(), 1, $test_name);
 618 }
 619
 620 {   my $test_name = "Only one FETCH (undef)";
 621     my $ok;
 622     $v = undef;
 623     is($f->count(), 0, "Sanity check: $test_name");
 624     no warnings "uninitialized";
 625     given(my $undef) {
 626         when(sub{0}->()) {}
 627         when("21")  {}
 628         when("22")  {}
 629         when($v)    {$ok = 1}
 630         when(undef) {$ok = 0}
 631     }
 632     is($ok, 1, "precheck: $test_name");
 633     is($f->count(), 1, $test_name);
 634 }
 635
 636 # Loop topicalizer
 637 {
 638     my $first = 1;
 639     for (1, "two") {
 640         when ("two") {
 641             is($first, 0, "Loop: second");
 642             eval {break};
 643             like($@, qr/^Can't "break" in a loop topicalizer/,
 644                 q{Can't "break" in a loop topicalizer});
 645         }
 646         when (1) {
 647             is($first, 1, "Loop: first");
 648             $first = 0;
 649             # Implicit break is okay
 650         }
 651     }
 652 }
 653
 654 {
 655     my $first = 1;
 656     for $_ (1, "two") {
 657         when ("two") {
 658             is($first, 0, "Explicit \$_: second");
 659             eval {break};
 660             like($@, qr/^Can't "break" in a loop topicalizer/,
 661                 q{Can't "break" in a loop topicalizer});
 662         }
 663         when (1) {
 664             is($first, 1, "Explicit \$_: first");
 665             $first = 0;
 666             # Implicit break is okay
 667         }
 668     }
 669 }
 670
 671 {
 672     my $first = 1;
 673     my $_;
 674     for (1, "two") {
 675         when ("two") {
 676             is($first, 0, "Implicitly lexical loop: second");
 677             eval {break};
 678             like($@, qr/^Can't "break" in a loop topicalizer/,
 679                 q{Can't "break" in a loop topicalizer});
 680         }
 681         when (1) {
 682             is($first, 1, "Implicitly lexical loop: first");
 683             $first = 0;
 684             # Implicit break is okay
 685         }
 686     }
 687 }
 688
 689 {
 690     my $first = 1;
 691     my $_;
 692     for $_ (1, "two") {
 693         when ("two") {
 694             is($first, 0, "Implicitly lexical, explicit \$_: second");
 695             eval {break};
 696             like($@, qr/^Can't "break" in a loop topicalizer/,
 697                 q{Can't "break" in a loop topicalizer});
 698         }
 699         when (1) {
 700             is($first, 1, "Implicitly lexical, explicit \$_: first");
 701             $first = 0;
 702             # Implicit break is okay
 703         }
 704     }
 705 }
 706
 707 {
 708     my $first = 1;
 709     for my $_ (1, "two") {
 710         when ("two") {
 711             is($first, 0, "Lexical loop: second");
 712             eval {break};
 713             like($@, qr/^Can't "break" in a loop topicalizer/,
 714                 q{Can't "break" in a loop topicalizer});
 715         }
 716         when (1) {
 717             is($first, 1, "Lexical loop: first");
 718             $first = 0;
 719             # Implicit break is okay
 720         }
 721     }
 722 }
 723
 724
 725 # Code references
 726 {
 727     no warnings "redefine";
 728     my $called_foo = 0;
 729     sub foo {$called_foo = 1; "@_" eq "foo"}
 730     my $called_bar = 0;
 731     sub bar {$called_bar = 1; "@_" eq "bar"}
 732     my ($matched_foo, $matched_bar) = (0, 0);
 733     given("foo") {
 734         when(\&bar) {$matched_bar = 1}
 735         when(\&foo) {$matched_foo = 1}
 736     }
 737     is($called_foo, 1,  "foo() was called");
 738     is($called_bar, 1,  "bar() was called");
 739     is($matched_bar, 0, "bar didn't match");
 740     is($matched_foo, 1, "foo did match");
 741 }
 742
 743 sub contains_x {
 744     my $x = shift;
 745     return ($x =~ /x/);
 746 }
 747 {
 748     my ($ok1, $ok2) = (0,0);
 749     given("foxy!") {
 750         when(contains_x($_))
 751             { $ok1 = 1; continue }
 752         when(\&contains_x)
 753             { $ok2 = 1; continue }
 754     }
 755     is($ok1, 1, "Calling sub directly (true)");
 756     is($ok2, 1, "Calling sub indirectly (true)");
 757
 758     given("foggy") {
 759         when(contains_x($_))
 760             { $ok1 = 2; continue }
 761         when(\&contains_x)
 762             { $ok2 = 2; continue }
 763     }
 764     is($ok1, 1, "Calling sub directly (false)");
 765     is($ok2, 1, "Calling sub indirectly (false)");
 766 }
 767
 768 SKIP: {
 769     skip "Scalar/Util.pm not yet available", 20
 770         unless -r "$INC[0]/Scalar/Util.pm";
 771     # Test overloading
 772     { package OverloadTest;
 773
 774       use overload '""' => sub{"string value of obj"};
 775       use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 776
 777       use overload "~~" => sub {
 778           my ($self, $other, $reversed) = @_;
 779           if ($reversed) {
 780               $self->{left}  = $other;
 781               $self->{right} = $self;
 782               $self->{reversed} = 1;
 783           } else {
 784               $self->{left}  = $self;
 785               $self->{right} = $other;
 786               $self->{reversed} = 0;
 787           }
 788           $self->{called} = 1;
 789           return $self->{retval};
 790       };
 791
 792       sub new {
 793           my ($pkg, $retval) = @_;
 794           bless {
 795                  called => 0,
 796                  retval => $retval,
 797                 }, $pkg;
 798       }
 799   }
 800
 801     {
 802         my $test = "Overloaded obj in given (true)";
 803         my $obj = OverloadTest->new(1);
 804         my $matched;
 805         given($obj) {
 806             when ("other arg") {$matched = 1}
 807             default {$matched = 0}
 808         }
 809
 810         is($obj->{called}, 0, "$test: called");
 811         ok(!$matched, "$test: not matched");
 812     }
 813
 814     {
 815         my $test = "Overloaded obj in given (false)";
 816         my $obj = OverloadTest->new(0);
 817         my $matched;
 818         given($obj) {
 819             when ("other arg") {$matched = 1}
 820         }
 821
 822         is($obj->{called}, 0, "$test: called");
 823         ok(!$matched, "$test: not matched");
 824     }
 825
 826     {
 827         my $test = "Overloaded obj in when (true)";
 828         my $obj = OverloadTest->new(1);
 829         my $matched;
 830         given("topic") {
 831             when ($obj) {$matched = 1}
 832             default {$matched = 0}
 833         }
 834
 835         is($obj->{called},  1, "$test: called");
 836         ok($matched, "$test: matched");
 837         is($obj->{left}, "topic", "$test: left");
 838         is($obj->{right}, "string value of obj", "$test: right");
 839         ok($obj->{reversed}, "$test: reversed");
 840     }
 841
 842     {
 843         my $test = "Overloaded obj in when (false)";
 844         my $obj = OverloadTest->new(0);
 845         my $matched;
 846         given("topic") {
 847             when ($obj) {$matched = 1}
 848             default {$matched = 0}
 849         }
 850
 851         is($obj->{called}, 1, "$test: called");
 852         ok(!$matched, "$test: not matched");
 853         is($obj->{left}, "topic", "$test: left");
 854         is($obj->{right}, "string value of obj", "$test: right");
 855         ok($obj->{reversed}, "$test: reversed");
 856     }
 857 }
 858
 859 # Postfix when
 860 {
 861     my $ok;
 862     given (undef) {
 863         $ok = 1 when undef;
 864     }
 865     is($ok, 1, "postfix undef");
 866 }
 867 {
 868     my $ok;
 869     given (2) {
 870         $ok += 1 when 7;
 871         $ok += 2 when 9.1685;
 872         $ok += 4 when $_ > 4;
 873         $ok += 8 when $_ < 2.5;
 874     }
 875     is($ok, 8, "postfix numeric");
 876 }
 877 {
 878     my $ok;
 879     given ("apple") {
 880         $ok = 1, continue when $_ eq "apple";
 881         $ok += 2;
 882         $ok = 0 when "banana";
 883     }
 884     is($ok, 3, "postfix string");
 885 }
 886 {
 887     my $ok;
 888     given ("pear") {
 889         do { $ok = 1; continue } when /pea/;
 890         $ok += 2;
 891         $ok = 0 when /pie/;
 892         default { $ok += 4 }
 893         $ok = 0;
 894     }
 895     is($ok, 7, "postfix regex");
 896 }
 897 # be_true is defined at the beginning of the file
 898 {
 899     my $x = "what";
 900     given(my $x = "foo") {
 901         do {
 902             is($x, "foo", "scope inside ... when my \$x = ...");
 903             continue;
 904         } when be_true(my $x = "bar");
 905         is($x, "bar", "scope after ... when my \$x = ...");
 906     }
 907 }
 908 {
 909     my $x = 0;
 910     given(my $x = 1) {
 911         my $x = 2, continue when be_true();
 912         is($x, undef, "scope after my \$x = ... when ...");
 913     }
 914 }
 915
 916 # Tests for last and next in when clauses
 917 my $letter;
 918
 919 $letter = '';
 920 for ("a".."e") {
 921     given ($_) {
 922         $letter = $_;
 923         when ("b") { last }
 924     }
 925     $letter = "z";
 926 }
 927 is($letter, "b", "last in when");
 928
 929 $letter = '';
 930 LETTER1: for ("a".."e") {
 931     given ($_) {
 932         $letter = $_;
 933         when ("b") { last LETTER1 }
 934     }
 935     $letter = "z";
 936 }
 937 is($letter, "b", "last LABEL in when");
 938
 939 $letter = '';
 940 for ("a".."e") {
 941     given ($_) {
 942         when (/b|d/) { next }
 943         $letter .= $_;
 944     }
 945     $letter .= ',';
 946 }
 947 is($letter, "a,c,e,", "next in when");
 948
 949 $letter = '';
 950 LETTER2: for ("a".."e") {
 951     given ($_) {
 952         when (/b|d/) { next LETTER2 }
 953         $letter .= $_;
 954     }
 955     $letter .= ',';
 956 }
 957 is($letter, "a,c,e,", "next LABEL in when");
 958
 959 # Okay, that'll do for now. The intricacies of the smartmatch
 960 # semantics are tested in t/op/smartmatch.t
 961 __END__