Properly return a syntax error instead of segfaulting if each/keys/values is used...

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

diff --git a/t/op/switch.t b/t/op/switch.t
index f4cedba..80d6b98 100644 (file)
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -3,20 +3,19 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
 use strict;
 use warnings;
 
-use Test::More tests => 124;
+plan tests => 128;
 
 # 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
 # the switch ops themselves.
-              
 
 use feature 'switch';
-no warnings "numeric";
 
 eval { continue };
 like($@, qr/^Can't "continue" outside/, "continue outside");
@@ -134,15 +133,15 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
 }
 {
     no warnings "uninitialized";
-    my $ok = 0;
-    given (undef) { when(0) {$ok = 1} }
+    my $ok = 1;
+    given (undef) { when(0) {$ok = 0} }
     is($ok, 1, "Given(undef) when(0)");
 }
 {
     no warnings "uninitialized";
     my $undef;
-    my $ok = 0;
-    given ($undef) { when(0) {$ok = 1} }
+    my $ok = 1;
+    given ($undef) { when(0) {$ok = 0} }
     is($ok, 1, 'Given($undef) when(0)');
 }
 ########
@@ -159,15 +158,15 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
 }
 {
     no warnings "uninitialized";
-    my $ok = 0;
-    given (undef) { when("") {$ok = 1} }
+    my $ok = 1;
+    given (undef) { when("") {$ok = 0} }
     is($ok, 1, 'Given(undef) when("")');
 }
 {
     no warnings "uninitialized";
     my $undef;
-    my $ok = 0;
-    given ($undef) { when("") {$ok = 1} }
+    my $ok = 1;
+    given ($undef) { when("") {$ok = 0} }
     is($ok, 1, 'Given($undef) when("")');
 }
 ########
@@ -414,6 +413,15 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 'y', "Optimized-away comparison");
 }
 
+{
+    my $ok;
+    given(23) {
+        when (scalar 24) { $ok = 'n'; continue }
+        default { $ok = 'y' }
+    }
+    is($ok,'y','scalar()');
+}
+
 # File tests
 #  (How to be both thorough and portable? Pinch a few ideas
 #  from t/op/filetest.t. We err on the side of portability for
@@ -517,6 +525,17 @@ sub notfoo {"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 $n = 0;
+    for my $l qw(a b c d) {
+       given ($l) {
            when ($_ eq "b" ... $_ eq "c") { $n = 1 }
            default { $n = 0 }
        }
@@ -724,7 +743,6 @@ my $f = tie my $v, "FetchCounter";
 
 # Code references
 {
-    no warnings "redefine";
     my $called_foo = 0;
     sub foo {$called_foo = 1; "@_" eq "foo"}
     my $called_bar = 0;
@@ -772,6 +790,7 @@ SKIP: {
     { package OverloadTest;
 
       use overload '""' => sub{"string value of obj"};
+      use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 
       use overload "~~" => sub {
          my ($self, $other, $reversed) = @_;
@@ -806,11 +825,8 @@ SKIP: {
            default {$matched = 0}
        }
     
-       is($obj->{called},  1, "$test: called");
+       is($obj->{called}, 1, "$test: called");
        ok($matched, "$test: matched");
-       is($obj->{left}, "string value of obj", "$test: left");
-       is($obj->{right}, "other arg", "$test: right");
-       ok(!$obj->{reversed}, "$test: not reversed");
     }
 
     {
@@ -821,11 +837,8 @@ SKIP: {
            when ("other arg") {$matched = 1}
        }
     
-       is($obj->{called},  1, "$test: called");
+       is($obj->{called}, 1, "$test: called");
        ok(!$matched, "$test: not matched");
-       is($obj->{left}, "string value of obj", "$test: left");
-       is($obj->{right}, "other arg", "$test: right");
-       ok(!$obj->{reversed}, "$test: not reversed");
     }
 
     {
@@ -961,6 +974,56 @@ LETTER2: for ("a".."e") {
 }
 is($letter, "a,c,e,", "next LABEL in when");
 
+# Test goto with given/when
+{
+    my $flag = 0;
+    goto GIVEN1;
+    $flag = 1;
+    GIVEN1: given ($flag) {
+       when (0) { break; }
+       $flag = 2;
+    }
+    is($flag, 0, "goto GIVEN1");
+}
+{
+    my $flag = 0;
+    given ($flag) {
+       when (0) { $flag = 1; }
+       goto GIVEN2;
+       $flag = 2;
+    }
+GIVEN2:
+    is($flag, 1, "goto inside given");
+}
+{
+    my $flag = 0;
+    given ($flag) {
+       when (0) { $flag = 1; goto GIVEN3; $flag = 2; }
+       $flag = 3;
+    }
+GIVEN3:
+    is($flag, 1, "goto inside given and when");
+}
+{
+    my $flag = 0;
+    for ($flag) {
+       when (0) { $flag = 1; goto GIVEN4; $flag = 2; }
+       $flag = 3;
+    }
+GIVEN4:
+    is($flag, 1, "goto inside for and when");
+}
+{
+    my $flag = 0;
+GIVEN5:
+    given ($flag) {
+       when (0) { $flag = 1; goto GIVEN5; $flag = 2; }
+       when (1) { break; }
+       $flag = 3;
+    }
+    is($flag, 1, "goto inside given and when to the given stmt");
+}
+
 # Okay, that'll do for now. The intricacies of the smartmatch
 # semantics are tested in t/op/smartmatch.t
 __END__