Fix test for stringification of arrays.

[p5sagit/p5-mst-13.2.git] / t / op / switch.t

diff --git a/t/op/switch.t b/t/op/switch.t
index 9fa5b08..f4cedba 100644 (file)
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -8,7 +8,7 @@ BEGIN {
 use strict;
 use warnings;
 
-use Test::More tests => 118;
+use Test::More tests => 124;
 
 # The behaviour of the feature pragma should be tested by lib/switch.t
 # using the tests in t/lib/switch/*. This file tests the behaviour of
@@ -133,14 +133,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, "Given(0) when($undef++)");
 }
 {
-    my $ok = 1;
-    given (undef) { when(0) {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when(0) {$ok = 1} }
     is($ok, 1, "Given(undef) when(0)");
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when(0) {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when(0) {$ok = 1} }
     is($ok, 1, 'Given($undef) when(0)');
 }
 ########
@@ -156,14 +158,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, 'Given("") when($undef)');
 }
 {
-    my $ok = 1;
-    given (undef) { when("") {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given(undef) when("")');
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when("") {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given($undef) when("")');
 }
 ########
@@ -428,11 +432,11 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
 }
 
 # Sub and method calls
-sub bar {"bar"}
+sub notfoo {"bar"}
 {
     my $ok = 0;
     given("foo") {
-       when(bar()) {$ok = 1}
+       when(notfoo()) {$ok = 1}
     }
     ok($ok, "Sub call acts as boolean")
 }
@@ -440,7 +444,7 @@ sub bar {"bar"}
 {
     my $ok = 0;
     given("foo") {
-       when(main->bar()) {$ok = 1}
+       when(main->notfoo()) {$ok = 1}
     }
     ok($ok, "Class-method call acts as boolean")
 }
@@ -449,7 +453,7 @@ sub bar {"bar"}
     my $ok = 0;
     my $obj = bless [];
     given("foo") {
-       when($obj->bar()) {$ok = 1}
+       when($obj->notfoo()) {$ok = 1}
     }
     ok($ok, "Object-method call acts as boolean")
 }
@@ -510,6 +514,17 @@ sub bar {"bar"}
 }
 
 {
+    my $n = 0;
+    for my $l qw(a b c d) {
+       given ($l) {
+           when ($_ eq "b" ... $_ eq "c") { $n = 1 }
+           default { $n = 0 }
+       }
+       ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
+    }
+}
+
+{
     my $ok = 0;
     given("foo") {
        when((1 == $ok) || "foo") {
@@ -519,67 +534,14 @@ sub bar {"bar"}
     ok($ok, '((1 == $ok) || "foo") smartmatched');
 }
 
-TODO: {
-    local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match";
-    { # this should smart match on each side of &&
-       my @n = qw(fred barney betty);
-       my @m = @n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( @n ) {
-               $ok++; continue;
-       }
-       when( @m ) {
-               $ok++; continue;
-       }
-       when( @m && @n ) {
-               $ok++;
-       }
-       }
-
-       is($ok, 3, '(@n && @m) smart-matched'); 
-    }
-
-    { # this should smart match on each side of &&
-       my @n = qw(fred barney betty);
-       my %n = map { $_, 1 } @n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( @n ) {
-               $ok++; continue;
-       }
-       when( %n ) {
-               $ok++; continue;
-       }
-       when( @n && %n ) {
-               $ok++;
-       }
-       }
-
-       is($ok, 3, '(@n && %n) smart-matched'); 
-    }
-
-    { # this should smart match on each side of &&
-       my %n = map { $_, 1 } qw(fred barney betty);
-       my %m = %n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( %m ) {
-               $ok++; continue;
-       }
-       when( %n ) {
-               $ok++; continue;
-       }
-       when( %m && %n ) {
-               $ok++;
-       }
+{
+    my $ok = 0;
+    given("foo") {
+       when((1 == $ok || undef) // "foo") {
+           $ok = 1;
        }
-
-       is($ok, 3, '(%m && %n) smart-matched'); 
     }
+    ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 }
 
 # Make sure we aren't invoking the get-magic more than once
@@ -659,6 +621,7 @@ my $f = tie my $v, "FetchCounter";
     my $ok;
     $v = undef;
     is($f->count(), 0, "Sanity check: $test_name");
+    no warnings "uninitialized";
     given(my $undef) {
        when(sub{0}->()) {}
        when("21")  {}
@@ -763,18 +726,18 @@ my $f = tie my $v, "FetchCounter";
 {
     no warnings "redefine";
     my $called_foo = 0;
-    sub foo {$called_foo = 1}
+    sub foo {$called_foo = 1; "@_" eq "foo"}
     my $called_bar = 0;
-    sub bar {$called_bar = 1}
+    sub bar {$called_bar = 1; "@_" eq "bar"}
     my ($matched_foo, $matched_bar) = (0, 0);
-    given(\&foo) {
+    given("foo") {
        when(\&bar) {$matched_bar = 1}
        when(\&foo) {$matched_foo = 1}
     }
-    is($called_foo, 0,  "Code ref comparison: foo not called");
-    is($called_bar, 0,  "Code ref comparison: bar not called");
-    is($matched_bar, 0, "Code ref didn't match different one");
-    is($matched_foo, 1, "Code ref did match itself");
+    is($called_foo, 1,  "foo() was called");
+    is($called_bar, 1,  "bar() was called");
+    is($matched_bar, 0, "bar didn't match");
+    is($matched_foo, 1, "foo did match");
 }
 
 sub contains_x {
@@ -955,6 +918,48 @@ SKIP: {
     }
 }
 
+# Tests for last and next in when clauses
+my $letter;
+
+$letter = '';
+for ("a".."e") {
+    given ($_) {
+       $letter = $_;
+       when ("b") { last }
+    }
+    $letter = "z";
+}
+is($letter, "b", "last in when");
+
+$letter = '';
+LETTER1: for ("a".."e") {
+    given ($_) {
+       $letter = $_;
+       when ("b") { last LETTER1 }
+    }
+    $letter = "z";
+}
+is($letter, "b", "last LABEL in when");
+
+$letter = '';
+for ("a".."e") {
+    given ($_) {
+       when (/b|d/) { next }
+       $letter .= $_;
+    }
+    $letter .= ',';
+}
+is($letter, "a,c,e,", "next in when");
+
+$letter = '';
+LETTER2: for ("a".."e") {
+    given ($_) {
+       when (/b|d/) { next LETTER2 }
+       $letter .= $_;
+    }
+    $letter .= ',';
+}
+is($letter, "a,c,e,", "next LABEL in when");
 
 # Okay, that'll do for now. The intricacies of the smartmatch
 # semantics are tested in t/op/smartmatch.t