BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
+ require './test.pl';
}
use strict;
use warnings;
-use Test::More tests => 122;
+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");
is($ok, 1, "Given(0) when($undef++)");
}
{
+ no warnings "uninitialized";
my $ok = 1;
given (undef) { when(0) {$ok = 0} }
is($ok, 1, "Given(undef) when(0)");
}
{
+ no warnings "uninitialized";
my $undef;
my $ok = 1;
given ($undef) { when(0) {$ok = 0} }
is($ok, 1, 'Given("") when($undef)');
}
{
+ no warnings "uninitialized";
my $ok = 1;
given (undef) { when("") {$ok = 0} }
is($ok, 1, 'Given(undef) when("")');
}
{
+ no warnings "uninitialized";
my $undef;
my $ok = 1;
given ($undef) { when("") {$ok = 0} }
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
}
# 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")
}
{
my $ok = 0;
given("foo") {
- when(main->bar()) {$ok = 1}
+ when(main->notfoo()) {$ok = 1}
}
ok($ok, "Class-method call acts as boolean")
}
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")
}
}
{
- my $ok = 0;
- given("foo") {
- when((1 == $ok) || "foo") {
- $ok = 1;
+ 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');
}
- 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++;
- }
+{
+ my $n = 0;
+ for my $l qw(a b c d) {
+ given ($l) {
+ when ($_ eq "b" ... $_ eq "c") { $n = 1 }
+ default { $n = 0 }
}
-
- is($ok, 3, '(@n && @m) smart-matched');
+ ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
}
+}
- { # 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++;
- }
+{
+ my $ok = 0;
+ given("foo") {
+ when((1 == $ok) || "foo") {
+ $ok = 1;
}
-
- is($ok, 3, '(@n && %n) smart-matched');
}
+ ok($ok, '((1 == $ok) || "foo") smartmatched');
+}
- { # 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
my $ok;
$v = undef;
is($f->count(), 0, "Sanity check: $test_name");
+ no warnings "uninitialized";
given(my $undef) {
when(sub{0}->()) {}
when("21") {}
# Code references
{
- 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 {
{ package OverloadTest;
use overload '""' => sub{"string value of obj"};
+ use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
use overload "~~" => sub {
my ($self, $other, $reversed) = @_;
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");
}
{
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");
}
{
}
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__
projects / p5sagit/p5-mst-13.2.git / blobdiff