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