latest switch/say/~~

Message-Id: <20051217204431.GB28940@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@26400

8 files changed, 1293 insertions, 1 deletions

diff --git a/t/io/say.t b/t/io/say.t
new file mode 100644
index 0000000000..62cec80237
--- /dev/null
+++ b/t/io/say.t
@@ -0,0 +1,49 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+# Just a few very basic tests cribbed from t/io/print.t,
+# with some minor additions. say is actually compiled to
+# a print opcode, so it's more or less guaranteed to behave
+# the same way as print in any case.
+
+use strict 'vars';
+eval 'use Errno';
+die $@ if $@ and !$ENV{PERL_CORE_MINITEST};
+
+use feature "say";
+
+say "1..11";
+
+my $foo = 'STDOUT';
+say $foo "ok 1";
+
+say "ok 2\n","ok 3\n","ok 4";
+say STDOUT "ok 5";
+
+open(FOO,">-");
+say FOO "ok 6";
+
+open(my $bar,">-");
+say $bar "ok 7";
+
+say {"STDOUT"} "ok 8";
+
+if (!exists &Errno::EBADF) {
+    print "ok 9 # skipped: no EBADF\n";
+} else {
+    $! = 0;
+    no warnings 'unopened';
+    say NONEXISTENT "foo";
+    print "not " if ($! != &Errno::EBADF);
+    say "ok 9";
+}
+
+$_ = "ok 10";
+say;
+
+$_ = "ok 11";
+say STDOUT;
diff --git a/t/lib/feature/nonesuch b/t/lib/feature/nonesuch
new file mode 100644
index 0000000000..1de44f621b
--- /dev/null
+++ b/t/lib/feature/nonesuch
@@ -0,0 +1,12 @@
+Test that non-existent features fail as expected.
+
+__END__
+use feature "nonesuch";
+EXPECT
+OPTIONS regex
+^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1
+########
+no feature "nonesuch";
+EXPECT
+OPTIONS regex
+^Feature "nonesuch" is not supported by Perl [v0-9.]+ at - line 1
diff --git a/t/lib/feature/say b/t/lib/feature/say
new file mode 100644
index 0000000000..4b507e6d57
--- /dev/null
+++ b/t/lib/feature/say
@@ -0,0 +1,64 @@
+Check the lexical scoping of the say keyword.
+(The actual behaviour is tested in t/op/say.t)
+
+__END__
+# No say; should be a syntax error.
+use warnings;
+say "Hello", "world";
+EXPECT
+Unquoted string "say" may clash with future reserved word at - line 3.
+String found where operator expected at - line 3, near "say "Hello""
+	(Do you need to predeclare say?)
+syntax error at - line 3, near "say "Hello""
+Execution of - aborted due to compilation errors.
+########
+# With say, should work
+use warnings;
+use feature "say";
+say "Hello", "world";
+EXPECT
+Helloworld
+########
+# With say, should work in eval too
+use warnings;
+use feature "say";
+eval q(say "Hello", "world");
+EXPECT
+Helloworld
+########
+# feature out of scope; should be a syntax error.
+use warnings;
+{ use feature 'say'; }
+say "Hello", "world";
+EXPECT
+Unquoted string "say" may clash with future reserved word at - line 4.
+String found where operator expected at - line 4, near "say "Hello""
+	(Do you need to predeclare say?)
+syntax error at - line 4, near "say "Hello""
+Execution of - aborted due to compilation errors.
+########
+# 'no feature' should work
+use warnings;
+use feature 'say';
+say "Hello", "world";
+no feature;
+say "Hello", "world";
+EXPECT
+Unquoted string "say" may clash with future reserved word at - line 6.
+String found where operator expected at - line 6, near "say "Hello""
+	(Do you need to predeclare say?)
+syntax error at - line 6, near "say "Hello""
+Execution of - aborted due to compilation errors.
+########
+# 'no feature "say"' should work too
+use warnings;
+use feature 'say';
+say "Hello", "world";
+no feature 'say';
+say "Hello", "world";
+EXPECT
+Unquoted string "say" may clash with future reserved word at - line 6.
+String found where operator expected at - line 6, near "say "Hello""
+	(Do you need to predeclare say?)
+syntax error at - line 6, near "say "Hello""
+Execution of - aborted due to compilation errors.
diff --git a/t/lib/feature/smartmatch b/t/lib/feature/smartmatch
new file mode 100644
index 0000000000..16ea7f8a92
--- /dev/null
+++ b/t/lib/feature/smartmatch
@@ -0,0 +1,45 @@
+Check the lexical scoping of the switch keywords.
+(The actual behaviour is tested in t/op/smartmatch.t)
+
+__END__
+# No ~~; should be a syntax error.
+use warnings;
+print +(2 ~~ 2);
+EXPECT
+syntax error at - line 3, near "2 ~"
+Execution of - aborted due to compilation errors.
+########
+# With ~~, should work
+use warnings;
+use feature "~~";
+print +(2 ~~ 2);
+EXPECT
+1
+########
+# ~~ out of scope; should be a syntax error.
+use warnings;
+{ use feature '~~'; }
+print +(2 ~~ 2);
+EXPECT
+syntax error at - line 4, near "2 ~"
+Execution of - aborted due to compilation errors.
+########
+# 'no feature' should work
+use warnings;
+use feature '~~';
+print +(2 ~~ 2), "\n";
+no feature;
+print +(2 ~~ 2), "\n";
+EXPECT
+syntax error at - line 6, near "2 ~"
+Execution of - aborted due to compilation errors.
+########
+# 'no feature "~~"' should work too
+use warnings;
+use feature '~~';
+print +(2 ~~ 2), "\n";
+no feature "~~";
+print +(2 ~~ 2), "\n";
+EXPECT
+syntax error at - line 6, near "2 ~"
+Execution of - aborted due to compilation errors.
diff --git a/t/lib/feature/switch b/t/lib/feature/switch
new file mode 100644
index 0000000000..022cbd1761
--- /dev/null
+++ b/t/lib/feature/switch
@@ -0,0 +1,158 @@
+Check the lexical scoping of the switch keywords.
+(The actual behaviour is tested in t/op/switch.t)
+
+__END__
+# No switch; given should be a bareword.
+use warnings;
+print STDOUT given;
+EXPECT
+Unquoted string "given" may clash with future reserved word at - line 3.
+given
+########
+# No switch; when should be a bareword.
+use warnings;
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 3.
+when
+########
+# No switch; default should be a bareword.
+use warnings;
+print STDOUT default;
+EXPECT
+Unquoted string "default" may clash with future reserved word at - line 3.
+default
+########
+# No switch; break should be a bareword.
+use warnings;
+print STDOUT break;
+EXPECT
+Unquoted string "break" may clash with future reserved word at - line 3.
+break
+########
+# No switch; but continue is still a keyword
+print STDOUT continue;
+EXPECT
+syntax error at - line 2, near "STDOUT continue"
+Execution of - aborted due to compilation errors.
+########
+# Use switch; so given is a keyword
+use feature 'switch';
+given("okay\n") { print }
+EXPECT
+okay
+########
+# Use switch; so when is a keyword
+use feature 'switch';
+given(1) { when(1) { print "okay" } }
+EXPECT
+okay
+########
+# Use switch; so default is a keyword
+use feature 'switch';
+given(1) { default { print "okay" } }
+EXPECT
+okay
+########
+# Use switch; so break is a keyword
+use feature 'switch';
+break;
+EXPECT
+Can't "break" outside a given block at - line 3.
+########
+# Use switch; so continue is a keyword
+use feature 'switch';
+continue;
+EXPECT
+Can't "continue" outside a when block at - line 3.
+########
+# switch out of scope; given should be a bareword.
+use warnings;
+{ use feature 'switch';
+  given (1) {print "Okay here\n";}
+}
+print STDOUT given;
+EXPECT
+Unquoted string "given" may clash with future reserved word at - line 6.
+Okay here
+given
+########
+# switch out of scope; when should be a bareword.
+use warnings;
+{ use feature 'switch';
+  given (1) { when(1) {print "Okay here\n";} }
+}
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# switch out of scope; default should be a bareword.
+use warnings;
+{ use feature 'switch';
+  given (1) { default {print "Okay here\n";} }
+}
+print STDOUT default;
+EXPECT
+Unquoted string "default" may clash with future reserved word at - line 6.
+Okay here
+default
+########
+# switch out of scope; break should be a bareword.
+use warnings;
+{ use feature 'switch';
+  given (1) { break }  
+}
+print STDOUT break;
+EXPECT
+Unquoted string "break" may clash with future reserved word at - line 6.
+break
+########
+# switch out of scope; continue should not work
+{ use feature 'switch';
+  given (1) { default {continue} }  
+}
+print STDOUT continue;
+EXPECT
+syntax error at - line 5, near "STDOUT continue"
+Execution of - aborted due to compilation errors.
+########
+# C<no feature 'switch'> should work
+use warnings;
+use feature 'switch';
+given (1) { when(1) {print "Okay here\n";} }
+no feature 'switch';
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# C<no feature> should work too
+use warnings;
+use feature 'switch';
+given (1) { when(1) {print "Okay here\n";} }
+no feature;
+print STDOUT when;
+EXPECT
+Unquoted string "when" may clash with future reserved word at - line 6.
+Okay here
+when
+########
+# Without the feature, no 'Unambiguous use of' warning:
+use warnings;
+@break = ($break = "break");
+print ${break}, ${break[0]};
+EXPECT
+breakbreak
+########
+# With the feature, we get an 'Unambiguous use of' warning:
+use warnings;
+use feature 'switch';
+@break = ($break = "break");
+print ${break}, ${break[0]};
+EXPECT
+Ambiguous use of ${break} resolved to $break at - line 5.
+Ambiguous use of ${break[...]} resolved to $break[...] at - line 5.
+breakbreak
diff --git a/t/op/cproto.t b/t/op/cproto.t
index d37118e045..3f3e871fa8 100644
--- a/t/op/cproto.t
+++ b/t/op/cproto.t
@@ -47,7 +47,7 @@ close (;*)
 closedir (*)
 cmp unknown
 connect (*$)
-continue unknown
+continue ()
 cos (;$)
 crypt ($$)
 dbmclose (\%)
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
new file mode 100644
index 0000000000..6275f40b0f
--- /dev/null
+++ b/t/op/smartmatch.t
@@ -0,0 +1,163 @@
+#!./perl
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+use strict;
+
+use Tie::Array;
+use Tie::Hash;
+
+# The feature mechanism is tested in t/lib/feature/smartmatch:
+# This file tests the semantics of the operator, without worrying
+# about feature issues such as scoping etc.
+
+# Predeclare vars used in the tests:
+my $deep1 = []; push @$deep1, \$deep1;
+my $deep2 = []; push @$deep2, \$deep2;
+
+{my $const = "a constant"; sub a_const () {$const}}
+
+my @nums = (1..10);
+tie my @tied_nums, 'Tie::StdArray';
+@tied_nums =  (1..10);
+
+my %hash = (foo => 17, bar => 23);
+tie my %tied_hash, 'Tie::StdHash';
+%tied_hash = %hash;
+
+# Load and run the tests
+my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
+plan tests => 2 * @tests;
+
+for my $test (@tests) {
+    my ($yn, $left, $right) = @$test;
+
+    match_test($yn, $left, $right);
+    match_test($yn, $right, $left);
+}
+
+sub match_test {
+    my ($yn, $left, $right) = @_;
+
+    die "Bad test spec: ($yn, $left, $right)"
+	unless $yn eq "" || $yn eq "!";
+    
+    my $tstr = "$left ~~ $right";
+    
+    my $res;
+    {
+	use feature "~~";
+	$res = eval $tstr // "";	#/ <- fix syntax colouring
+    }
+
+    die $@ if $@ ne "";
+    ok( ($yn =~ /!/ xor $res), "$tstr: $res");
+}
+
+
+
+sub foo {}
+sub bar {2}
+sub fatal {die}
+
+sub a_const() {die if @_; "a constant"}
+sub b_const() {die if @_; "a constant"}
+
+__DATA__
+# CODE ref against argument
+#  - arg is code ref
+	\&foo		\&foo
+!	\&foo		sub {}
+!	\&foo		\&bar
+
+# - arg is not code ref
+	1		sub{shift}
+!	0		sub{shift}
+	1		sub{scalar @_}
+	[]		\&bar
+	{}		\&bar
+	qr//		\&bar
+
+# - null-prototyped subs
+	a_const		"a constant"
+	a_const		a_const
+	a_const		b_const
+
+# HASH ref against:
+#   - another hash ref
+	{}		{}
+!	{}		{1 => 2}
+	{1 => 2}	{1 => 2}
+	{1 => 2}	{1 => 3}
+!	{1 => 2}	{2 => 3}
+	\%main::	{map {$_ => 'x'} keys %main::}
+
+#  - tied hash ref
+	\%hash		\%tied_hash
+	\%tied_hash	\%tied_hash
+
+#  - an array ref
+	\%::		[keys %main::]
+!	\%::		[]
+	{"" => 1}	[undef]
+
+#  - a regex
+	{foo => 1}	qr/^(fo[ox])$/
+!	+{0..100}	qr/[13579]$/
+
+#  - a string
+	+{foo => 1, bar => 2}	"foo"
+!	+{foo => 1, bar => 2}	"baz"
+
+
+# ARRAY ref against:
+#  - another array ref
+	[]		[]
+!	[]		[1]
+	[["foo"], ["bar"]]	[qr/o/, qr/a/]
+	["foo", "bar"]		[qr/o/, qr/a/]
+	$deep1		$deep1
+!	$deep1		$deep2
+
+	\@nums		\@tied_nums
+
+#  - a regex
+	[qw(foo bar baz quux)]	qr/x/
+!	[qw(foo bar baz quux)]	qr/y/
+
+# - a number
+	[qw(1foo 2bar)]		2
+
+# - a string
+!	[qw(1foo 2bar)]		"2"
+
+# Number against number
+	2		2
+!	2		3
+
+# Number against string
+	2		"2"
+	2		"2.0"
+!	2		"2bananas"
+!	2_3		"2_3"
+
+# Regex against string
+	qr/x/		"x"
+!	qr/y/		"x"
+
+# Regex against number
+	12345		qr/3/
+
+
+# Test the implicit referencing
+	@nums		7
+	@nums		\@nums
+!	@nums		\\@nums
+	@nums		[1..10]
+!	@nums		[0..9]
+
+	%hash		"foo"
+	%hash		/bar/
diff --git a/t/op/switch.t b/t/op/switch.t
new file mode 100644
index 0000000000..fc88a13956
--- /dev/null
+++ b/t/op/switch.t
@@ -0,0 +1,801 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
+use warnings;
+
+use Test::More tests => 107;
+
+# 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");
+
+eval { break };
+like($@, qr/^Can't "break" outside/, "break outside");
+
+# Scoping rules
+
+{
+    my $x = "foo";
+    given(my $x = "bar") {
+	is($x, "bar", "given scope starts");
+    }
+    is($x, "foo", "given scope ends");
+}
+
+sub be_true {1}
+
+given(my $x = "foo") {
+    when(be_true(my $x = "bar")) {
+	is($x, "bar", "given scope starts");
+    }
+    is($x, "foo", "given scope ends");
+}
+
+$_ = "outside";
+given("inside") { check_outside1() }
+sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
+
+{
+    my $_ = "outside";
+    given("inside") { check_outside2() }
+    sub check_outside2 {
+	is($_, "outside", "\$_ lexically scoped (lexical \$_)")
+    }
+}
+
+# Basic string/numeric comparisons and control flow
+
+{    
+    my $ok = 0;
+    given(3) {
+	when(2) { $ok = 0; }
+	when(3) { $ok = 1; }
+	when(4) { $ok = 0; }
+	default { $ok = 0; }
+    }
+    ok($ok, "numeric comparison");
+}
+
+{    
+    my $ok = 0;
+    use integer;
+    given(3.14159265) {
+	when(2) { $ok = 0; }
+	when(3) { $ok = 1; }
+	when(4) { $ok = 0; }
+	default { $ok = 0; }
+    }
+    ok($ok, "integer comparison");
+}
+
+{    
+    my ($ok1, $ok2) = (0, 0);
+    given(3) {
+	when(3.1)   { $ok1 = 0; }
+	when(3.0)   { $ok1 = 1; continue }
+	when("3.0") { $ok2 = 1; }
+	default     { $ok2 = 0; }
+    }
+    ok($ok1, "more numeric (pt. 1)");
+    ok($ok2, "more numeric (pt. 2)");
+}
+
+{
+    my $ok = 0;
+    given("c") {
+	when("b") { $ok = 0; }
+	when("c") { $ok = 1; }
+	when("d") { $ok = 0; }
+	default   { $ok = 0; }
+    }
+    ok($ok, "string comparison");
+}
+
+{
+    my $ok = 0;
+    given("c") {
+	when("b") { $ok = 0; }
+	when("c") { $ok = 0; continue }
+	when("c") { $ok = 1; }
+	default   { $ok = 0; }
+    }
+    ok($ok, "simple continue");
+}
+
+# Definedness
+{
+    my $ok = 1;
+    given (0) { when(undef) {$ok = 0} }
+    ok($ok, "Given(0) when(undef)");
+}
+{
+    my $undef;
+    my $ok = 1;
+    given (0) { when($undef) {$ok = 0} }
+    ok($ok, 'Given(0) when($undef)');
+}
+{
+    my $undef;
+    my $ok = 0;
+    given (0) { when($undef++) {$ok = 1} }
+    ok($ok, "Given(0) when($undef++)");
+}
+{
+    my $ok = 1;
+    given (undef) { when(0) {$ok = 0} }
+    ok($ok, "Given(undef) when(0)");
+}
+{
+    my $undef;
+    my $ok = 1;
+    given ($undef) { when(0) {$ok = 0} }
+    ok($ok, 'Given($undef) when(0)');
+}
+########
+{
+    my $ok = 1;
+    given ("") { when(undef) {$ok = 0} }
+    ok($ok, 'Given("") when(undef)');
+}
+{
+    my $undef;
+    my $ok = 1;
+    given ("") { when($undef) {$ok = 0} }
+    ok($ok, 'Given("") when($undef)');
+}
+{
+    my $ok = 1;
+    given (undef) { when("") {$ok = 0} }
+    ok($ok, 'Given(undef) when("")');
+}
+{
+    my $undef;
+    my $ok = 1;
+    given ($undef) { when("") {$ok = 0} }
+    ok($ok, 'Given($undef) when("")');
+}
+########
+{
+    my $ok = 0;
+    given (undef) { when(undef) {$ok = 1} }
+    ok($ok, "Given(undef) when(undef)");
+}
+{
+    my $undef;
+    my $ok = 0;
+    given (undef) { when($undef) {$ok = 1} }
+    ok($ok, 'Given(undef) when($undef)');
+}
+{
+    my $undef;
+    my $ok = 0;
+    given ($undef) { when(undef) {$ok = 1} }
+    ok($ok, 'Given($undef) when(undef)');
+}
+{
+    my $undef;
+    my $ok = 0;
+    given ($undef) { when($undef) {$ok = 1} }
+    ok($ok, 'Given($undef) when($undef)');
+}
+
+
+# Regular expressions
+{
+    my ($ok1, $ok2) = 0;
+    given("Hello, world!") {
+	when(/lo/)
+	    { $ok1 = 1; continue}
+	when(/no/)
+	    { $ok1 = 0; continue}
+	when(/^(Hello,|Goodbye cruel) world[!.?]/)
+	    { $ok2 = 1; continue}
+	when(/^(Hello cruel|Goodbye,) world[!.?]/)
+	    { $ok2 = 0; continue}
+    }
+    ok($ok1, "regex 1");
+    ok($ok2, "regex 2");
+}
+
+# Comparisons
+{
+    my $test = "explicit numeric comparison (<)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ < 10) { fail($test) }
+	when ($_ < 20) { fail($test) }
+	when ($_ < 30) { pass($test) }
+	when ($_ < 40) { fail($test) }
+	default        { fail($test) }
+    }
+}
+
+{
+    use integer;
+    my $test = "explicit numeric comparison (integer <)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ < 10) { fail($test) }
+	when ($_ < 20) { fail($test) }
+	when ($_ < 30) { pass($test) }
+	when ($_ < 40) { fail($test) }
+	default        { fail($test) }
+    }
+}
+
+{
+    my $test = "explicit numeric comparison (<=)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ <= 10) { fail($test) }
+	when ($_ <= 20) { fail($test) }
+	when ($_ <= 30) { pass($test) }
+	when ($_ <= 40) { fail($test) }
+	default         { fail($test) }
+    }
+}
+
+{
+    use integer;
+    my $test = "explicit numeric comparison (integer <=)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ <= 10) { fail($test) }
+	when ($_ <= 20) { fail($test) }
+	when ($_ <= 30) { pass($test) }
+	when ($_ <= 40) { fail($test) }
+	default         { fail($test) }
+    }
+}
+
+
+{
+    my $test = "explicit numeric comparison (>)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ > 40) { fail($test) }
+	when ($_ > 30) { fail($test) }
+	when ($_ > 20) { pass($test) }
+	when ($_ > 10) { fail($test) }
+	default        { fail($test) }
+    }
+}
+
+{
+    my $test = "explicit numeric comparison (>=)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ >= 40) { fail($test) }
+	when ($_ >= 30) { fail($test) }
+	when ($_ >= 20) { pass($test) }
+	when ($_ >= 10) { fail($test) }
+	default         { fail($test) }
+    }
+}
+
+{
+    use integer;
+    my $test = "explicit numeric comparison (integer >)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ > 40) { fail($test) }
+	when ($_ > 30) { fail($test) }
+	when ($_ > 20) { pass($test) }
+	when ($_ > 10) { fail($test) }
+	default        { fail($test) }
+    }
+}
+
+{
+    use integer;
+    my $test = "explicit numeric comparison (integer >=)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ >= 40) { fail($test) }
+	when ($_ >= 30) { fail($test) }
+	when ($_ >= 20) { pass($test) }
+	when ($_ >= 10) { fail($test) }
+	default         { fail($test) }
+    }
+}
+
+
+{
+    my $test = "explicit string comparison (lt)";
+    my $twenty_five = "25";
+    given($twenty_five) {
+	when ($_ lt "10") { fail($test) }
+	when ($_ lt "20") { fail($test) }
+	when ($_ lt "30") { pass($test) }
+	when ($_ lt "40") { fail($test) }
+	default         { fail($test) }
+    }
+}
+
+{
+    my $test = "explicit string comparison (le)";
+    my $twenty_five = "25";
+    given($twenty_five) {
+	when ($_ le "10") { fail($test) }
+	when ($_ le "20") { fail($test) }
+	when ($_ le "30") { pass($test) }
+	when ($_ le "40") { fail($test) }
+	default           { fail($test) }
+    }
+}
+
+{
+    my $test = "explicit string comparison (gt)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ ge "40") { fail($test) }
+	when ($_ ge "30") { fail($test) }
+	when ($_ ge "20") { pass($test) }
+	when ($_ ge "10") { fail($test) }
+	default           { fail($test) }
+    }
+}
+
+{
+    my $test = "explicit string comparison (ge)";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ ge "40") { fail($test) }
+	when ($_ ge "30") { fail($test) }
+	when ($_ ge "20") { pass($test) }
+	when ($_ ge "10") { fail($test) }
+	default           { fail($test) }
+    }
+}
+
+# Make sure it still works with a lexical $_:
+{
+    my $_;
+    my $test = "explicit comparison with lexical \$_";
+    my $twenty_five = 25;
+    given($twenty_five) {
+	when ($_ ge "40") { fail($test) }
+	when ($_ ge "30") { fail($test) }
+	when ($_ ge "20") { pass($test) }
+	when ($_ ge "10") { fail($test) }
+	default           { fail($test) }
+    }
+}
+
+# Optimized-away comparisons
+{
+    my $ok = 0;
+    given(23) {
+	when (2 + 2 == 4) { $ok = 1; continue }
+	when (2 + 2 == 5) { $ok = 0 }
+    }
+    ok($ok, "Optimized-away comparison");
+}
+
+# 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
+#  the time being.)
+
+{
+    my ($ok_d, $ok_f, $ok_r);
+    given("op") {
+	when(-d)  {$ok_d = 1; continue}
+	when(!-f) {$ok_f = 1; continue}
+	when(-r)  {$ok_r = 1; continue}
+    }
+    ok($ok_d, "Filetest -d");
+    ok($ok_f, "Filetest -f");
+    ok($ok_r, "Filetest -r");
+}
+
+# Sub and method calls
+sub bar {"bar"}
+{
+    my $ok = 0;
+    given("foo") {
+	when(bar()) {$ok = 1}
+    }
+    ok($ok, "Sub call acts as boolean")
+}
+
+{
+    my $ok = 0;
+    given("foo") {
+	when(main->bar()) {$ok = 1}
+    }
+    ok($ok, "Class-method call acts as boolean")
+}
+
+{
+    my $ok = 0;
+    my $obj = bless [];
+    given("foo") {
+	when($obj->bar()) {$ok = 1}
+    }
+    ok($ok, "Object-method call acts as boolean")
+}
+
+# Other things that should not be smart matched
+{
+    my $ok = 0;
+    given(0) {
+	when(eof(DATA)) {
+	    $ok = 1;
+	}
+    }
+    ok($ok, "eof() not smartmatched");
+}
+
+{
+    my $ok = 0;
+    my %foo = ("bar", 0);
+    given(0) {
+	when(exists $foo{bar}) {
+	    $ok = 1;
+	}
+    }
+    ok($ok, "exists() not smartmatched");
+}
+
+{
+    my $ok = 0;
+    given(0) {
+	when(defined $ok) {
+	    $ok = 1;
+	}
+    }
+    ok($ok, "defined() not smartmatched");
+}
+
+{
+    my $ok = 1;
+    given("foo") {
+	when((1 == 1) && "bar") {
+	    $ok = 0;
+	}
+	when((1 == 1) && $_ eq "foo") {
+	    $ok = 2;
+	}
+    }
+    is($ok, 2, "((1 == 1) && \"bar\") not smartmatched");
+}
+
+{
+    my $ok = 1;
+    given(0) {
+	when((1 == $ok) || "foo") {
+	    $ok = 0;
+	}
+    }
+    ok($ok, '((1 == $ok) || "foo") not smartmatched');
+}
+
+
+# Make sure we aren't invoking the get-magic more than once
+
+{ # A helper class to count the number of accesses.
+    package FetchCounter;
+    sub TIESCALAR {
+	my ($class) = @_;
+	bless {value => undef, count => 0}, $class;
+    }
+    sub STORE {
+        my ($self, $val) = @_;
+        $self->{count} = 0;
+        $self->{value} = $val;
+    }
+    sub FETCH {
+	my ($self) = @_;
+	# Avoid pre/post increment here
+	$self->{count} = 1 + $self->{count};
+	$self->{value};
+    }
+    sub count {
+	my ($self) = @_;
+	$self->{count};
+    }
+}
+
+my $f = tie my $v, "FetchCounter";
+
+{   my $test_name = "Only one FETCH (in given)";
+    my $ok = 0;
+    given($v = 23) {
+    	when(undef) {}
+    	when(sub{0}->()) {}
+	when(21) {}
+	when("22") {}
+	when(23) {$ok = 1}
+	when(/24/) {$ok = 0}
+    }
+    ok($ok, "precheck: $test_name");
+    is($f->count(), 1, $test_name);
+}
+
+{   my $test_name = "Only one FETCH (numeric when)";
+    my $ok = 0;
+    $v = 23;
+    is($f->count(), 0, "Sanity check: $test_name");
+    given(23) {
+    	when(undef) {}
+    	when(sub{0}->()) {}
+	when(21) {}
+	when("22") {}
+	when($v) {$ok = 1}
+	when(/24/) {$ok = 0}
+    }
+    ok($ok, "precheck: $test_name");
+    is($f->count(), 1, $test_name);
+}
+
+{   my $test_name = "Only one FETCH (string when)";
+    my $ok = 0;
+    $v = "23";
+    is($f->count(), 0, "Sanity check: $test_name");
+    given("23") {
+    	when(undef) {}
+    	when(sub{0}->()) {}
+	when("21") {}
+	when("22") {}
+	when($v) {$ok = 1}
+	when(/24/) {$ok = 0}
+    }
+    ok($ok, "precheck: $test_name");
+    is($f->count(), 1, $test_name);
+}
+
+{   my $test_name = "Only one FETCH (undef)";
+    my $ok = 0;
+    $v = undef;
+    is($f->count(), 0, "Sanity check: $test_name");
+    given(my $undef) {
+    	when(sub{0}->()) {}
+	when("21")  {}
+	when("22")  {}
+    	when($v)    {$ok = 1}
+	when(undef) {$ok = 0}
+    }
+    ok($ok, "precheck: $test_name");
+    is($f->count(), 1, $test_name);
+}
+
+# Loop topicalizer
+{
+    my $first = 1;
+    for (1, "two") {
+	when ("two") {
+	    is($first, 0, "Loop: second");
+	    eval {break};
+	    like($@, qr/^Can't "break" in a loop topicalizer/,
+	    	q{Can't "break" in a loop topicalizer});
+	}
+	when (1) {
+	    is($first, 1, "Loop: first");
+	    $first = 0;
+	    # Implicit break is okay
+	}
+    }
+}
+
+{
+    my $first = 1;
+    for $_ (1, "two") {
+	when ("two") {
+	    is($first, 0, "Explicit \$_: second");
+	    eval {break};
+	    like($@, qr/^Can't "break" in a loop topicalizer/,
+	    	q{Can't "break" in a loop topicalizer});
+	}
+	when (1) {
+	    is($first, 1, "Explicit \$_: first");
+	    $first = 0;
+	    # Implicit break is okay
+	}
+    }
+}
+
+{
+    my $first = 1;
+    my $_;
+    for (1, "two") {
+	when ("two") {
+	    is($first, 0, "Implicitly lexical loop: second");
+	    eval {break};
+	    like($@, qr/^Can't "break" in a loop topicalizer/,
+	    	q{Can't "break" in a loop topicalizer});
+	}
+	when (1) {
+	    is($first, 1, "Implicitly lexical loop: first");
+	    $first = 0;
+	    # Implicit break is okay
+	}
+    }
+}
+
+{
+    my $first = 1;
+    my $_;
+    for $_ (1, "two") {
+	when ("two") {
+	    is($first, 0, "Implicitly lexical, explicit \$_: second");
+	    eval {break};
+	    like($@, qr/^Can't "break" in a loop topicalizer/,
+	    	q{Can't "break" in a loop topicalizer});
+	}
+	when (1) {
+	    is($first, 1, "Implicitly lexical, explicit \$_: first");
+	    $first = 0;
+	    # Implicit break is okay
+	}
+    }
+}
+
+{
+    my $first = 1;
+    for my $_ (1, "two") {
+	when ("two") {
+	    is($first, 0, "Lexical loop: second");
+	    eval {break};
+	    like($@, qr/^Can't "break" in a loop topicalizer/,
+	    	q{Can't "break" in a loop topicalizer});
+	}
+	when (1) {
+	    is($first, 1, "Lecical loop: first");
+	    $first = 0;
+	    # Implicit break is okay
+	}
+    }
+}
+
+
+# Code references
+{
+    no warnings "redefine";
+    my $called_foo = 0;
+    sub foo {$called_foo = 1}
+    my $called_bar = 0;
+    sub bar {$called_bar = 1}
+    my ($matched_foo, $matched_bar) = (0, 0);
+    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");
+}
+
+sub contains_x {
+    my $x = shift;
+    return ($x =~ /x/);
+}
+{
+    my ($ok1, $ok2) = (0,0);
+    given("foxy!") {
+	when(contains_x($_))
+	    { $ok1 = 1; continue }
+	when(\&contains_x)
+	    { $ok2 = 1; continue }
+    }
+    is($ok1, 1, "Calling sub directly (true)");
+    is($ok2, 1, "Calling sub indirectly (true)");
+
+    given("foggy") {
+	when(contains_x($_))
+	    { $ok1 = 2; continue }
+	when(\&contains_x)
+	    { $ok2 = 2; continue }
+    }
+    is($ok1, 1, "Calling sub directly (false)");
+    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};
+    };
+    
+    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: 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: 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__