This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Add tests for @array ~~ $string
[perl5.git] / t / op / switch.t
diff --git a/t/op/switch.t b/t/op/switch.t
index d897157..de44082 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 => 108;
+use Test::More tests => 113;
 
 # 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,6 +534,15 @@ sub bar {"bar"}
     ok($ok, '((1 == $ok) || "foo") smartmatched');
 }
 
+{
+    my $ok = 0;
+    given("foo") {
+       when((1 == $ok || undef) // "foo") {
+           $ok = 1;
+       }
+    }
+    ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
+}
 
 # Make sure we aren't invoking the get-magic more than once
 
@@ -597,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")  {}
@@ -689,7 +714,7 @@ my $f = tie my $v, "FetchCounter";
                q{Can't "break" in a loop topicalizer});
        }
        when (1) {
-           is($first, 1, "Lecical loop: first");
+           is($first, 1, "Lexical loop: first");
            $first = 0;
            # Implicit break is okay
        }
@@ -701,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 {
@@ -740,98 +765,101 @@ sub contains_x {
     is($ok2, 1, "Calling sub indirectly (false)");
 }
 
-# Test overloading
-{ package OverloadTest;
-
-    use overload '""' => sub{"string value of obj"};
-
-    use overload "~~" => sub {
-        my ($self, $other, $reversed) = @_;
-        if ($reversed) {
-           $self->{left}  = $other;
-           $self->{right} = $self;
-           $self->{reversed} = 1;
-        } else {
-           $self->{left}  = $self;
-           $self->{right} = $other;
-           $self->{reversed} = 0;
-        }
-       $self->{called} = 1;
-       return $self->{retval};
-    };
+SKIP: {
+    skip "Scalar/Util.pm not yet available", 20
+       unless -r "$INC[0]/Scalar/Util.pm";
+    # Test overloading
+    { package OverloadTest;
+
+      use overload '""' => sub{"string value of obj"};
+
+      use overload "~~" => sub {
+         my ($self, $other, $reversed) = @_;
+         if ($reversed) {
+             $self->{left}  = $other;
+             $self->{right} = $self;
+             $self->{reversed} = 1;
+         } else {
+             $self->{left}  = $self;
+             $self->{right} = $other;
+             $self->{reversed} = 0;
+         }
+         $self->{called} = 1;
+         return $self->{retval};
+      };
     
-    sub new {
-       my ($pkg, $retval) = @_;
-       bless {
-           called => 0,
-           retval => $retval,
-       }, $pkg;
-    }
-}
-
-{
-    my $test = "Overloaded obj in given (true)";
-    my $obj = OverloadTest->new(1);
-    my $matched;
-    given($obj) {
-       when ("other arg") {$matched = 1}
-       default {$matched = 0}
-    }
+      sub new {
+         my ($pkg, $retval) = @_;
+         bless {
+                called => 0,
+                retval => $retval,
+               }, $pkg;
+      }
+  }
+
+    {
+       my $test = "Overloaded obj in given (true)";
+       my $obj = OverloadTest->new(1);
+       my $matched;
+       given($obj) {
+           when ("other arg") {$matched = 1}
+           default {$matched = 0}
+       }
     
-    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");
-}
-
-{
-    my $test = "Overloaded obj in given (false)";
-    my $obj = OverloadTest->new(0);
-    my $matched;
-    given($obj) {
-       when ("other arg") {$matched = 1}
-    }
+       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");
+    }
+
+    {
+       my $test = "Overloaded obj in given (false)";
+       my $obj = OverloadTest->new(0);
+       my $matched;
+       given($obj) {
+           when ("other arg") {$matched = 1}
+       }
     
-    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");
-}
-
-{
-    my $test = "Overloaded obj in when (true)";
-    my $obj = OverloadTest->new(1);
-    my $matched;
-    given("topic") {
-       when ($obj) {$matched = 1}
-       default {$matched = 0}
-    }
+       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");
+    }
+
+    {
+       my $test = "Overloaded obj in when (true)";
+       my $obj = OverloadTest->new(1);
+       my $matched;
+       given("topic") {
+           when ($obj) {$matched = 1}
+           default {$matched = 0}
+       }
     
-    is($obj->{called},  1, "$test: called");
-    ok($matched, "$test: matched");
-    is($obj->{left}, "topic", "$test: left");
-    is($obj->{right}, "string value of obj", "$test: right");
-    ok($obj->{reversed}, "$test: reversed");
-}
-
-{
-    my $test = "Overloaded obj in when (false)";
-    my $obj = OverloadTest->new(0);
-    my $matched;
-    given("topic") {
-       when ($obj) {$matched = 1}
-       default {$matched = 0}
-    }
+       is($obj->{called},  1, "$test: called");
+       ok($matched, "$test: matched");
+       is($obj->{left}, "topic", "$test: left");
+       is($obj->{right}, "string value of obj", "$test: right");
+       ok($obj->{reversed}, "$test: reversed");
+    }
+
+    {
+       my $test = "Overloaded obj in when (false)";
+       my $obj = OverloadTest->new(0);
+       my $matched;
+       given("topic") {
+           when ($obj) {$matched = 1}
+           default {$matched = 0}
+       }
     
-    is($obj->{called}, 1, "$test: called");
-    ok(!$matched, "$test: not matched");
-    is($obj->{left}, "topic", "$test: left");
-    is($obj->{right}, "string value of obj", "$test: right");
-    ok($obj->{reversed}, "$test: reversed");
+       is($obj->{called}, 1, "$test: called");
+       ok(!$matched, "$test: not matched");
+       is($obj->{left}, "topic", "$test: left");
+       is($obj->{right}, "string value of obj", "$test: right");
+       ok($obj->{reversed}, "$test: reversed");
+    }
 }
-
 # Okay, that'll do for now. The intricacies of the smartmatch
 # semantics are tested in t/op/smartmatch.t
 __END__
Unnamed repository; edit this file 'description' to name the repository.