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