From: Yuval Kogman <nothingmuch@woobling.org>
Date: Sat, 28 Jun 2008 22:40:36 +0000 (+0300)
Subject: More comprehensive smartmatch.t, supersedes smobj.t
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1cfb70492a75e71d0d138b31ac879fa68a42e0f3;p=p5sagit%2Fp5-mst-13.2.git

More comprehensive smartmatch.t, supersedes smobj.t
---

diff --git a/MANIFEST b/MANIFEST
index 217fd95..e97e615 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4118,7 +4118,6 @@ t/op/runlevel.t			See if die() works from perl_call_*()
 t/op/rxcode.t			See if /(?{ code })/ works
 t/op/sleep.t			See if sleep works
 t/op/smartmatch.t		See if the ~~ operator works
-t/op/smobj.t			See how the ~~ operator works with overloading
 t/op/sort.t			See if sort works
 t/op/splice.t			See if splice works
 t/op/split.t			See if split works
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index e57e2dd..4e66a1d 100644
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -28,6 +28,29 @@ my %hash = (foo => 17, bar => 23);
 tie my %tied_hash, 'Tie::StdHash';
 %tied_hash = %hash;
 
+{
+    package Test::Object::NoOverload;
+    sub new { bless { key => 1 } }
+}
+
+{
+    package Test::Object::CopyOverload;
+    sub new { bless { key => 1 } }
+    use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
+}
+
+{
+    package Test::Object::OverloadCodeRef;
+    sub new { bless $_[1] }
+    use overload '~~' => sub { shift->($_[1]) };
+}
+
+our $ov_obj = Test::Object::CopyOverload->new;
+our $obj = Test::Object::NoOverload->new;
+our $false_obj = Test::Object::OverloadCodeRef->new(sub { 0 });
+our $true_obj = Test::Object::OverloadCodeRef->new(sub { 1 });
+
+
 # Load and run the tests
 my @tests = map [chomp and split /\t+/, $_, 3], grep !/^#/ && /\S/, <DATA>;
 plan tests => 2 * @tests;
@@ -67,30 +90,72 @@ sub match_test {
 
 sub foo {}
 sub bar {2}
-sub fatal {die}
+sub gorch {2}
+sub fatal {die "fatal sub\n"}
 
-sub a_const() {die if @_; "a constant"}
-sub b_const() {die if @_; "a constant"}
+sub a_const() {die "const\n" if @_; "a constant"}
+sub b_const() {die "const\n" if @_; "a constant"}
 
 __DATA__
+# OBJECT
+# - overloaded
+	$ov_obj		"key"
+	$ov_obj		{"key" => 1}
+!	$ov_obj		"foo"
+!	$ov_obj		\&foo
+@	$ov_obj		\&fatal
+
+# regular object
+@	$obj	"key"
+@	$obj	{"key" => 1}
+@	$obj	"foo"
+@	$obj	$obj
+@	$obj	sub { 1 }
+@	$obj	sub { 0 }
+@	$obj	\&foo
+@	$obj	\&fatal
+
 # CODE ref against argument
 #  - arg is code ref
 	\&foo		\&foo
 !	\&foo		sub {}
 !	\&foo		\&bar
+	\&fatal		\&fatal
+!	\&foo		\&fatal
 
 # - arg is not code ref
-	1		sub{shift}
-!	0		sub{shift}
-	1		sub{scalar @_}
-	[]		\&bar
-	{}		\&bar
-	qr//		\&bar
+	1	sub{shift}
+!	0	sub{shift}
+!	undef	sub{shift}
+	undef	sub{not shift}
+	1	sub{scalar @_}
+	[]	\&bar
+	{}	\&bar
+	qr//	\&bar
+!	[]	\&foo
+!	{}	\&foo
+!	qr//	\&foo
+!	undef	\&foo
+	undef	\&bar
+@	undef	\&fatal
+@	1	\&fatal
+@	[]	\&fatal
+@	"foo"	\&fatal
+@	qr//	\&fatal
+@	$obj	\&bar
+	$ov_obj	\&bar
 
 # - null-prototyped subs
 	a_const		"a constant"
 	a_const		a_const
 	a_const		b_const
+	\&a_const	\&a_const
+!	\&a_const	\&b_const
+
+# - non-null-prototyped subs
+!	\&bar		\&gorch
+	bar		gorch
+@	fatal		bar
 
 # HASH ref against:
 #   - another hash ref
@@ -127,15 +192,15 @@ __DATA__
 
 # ARRAY ref against:
 #  - another array ref
-	[]		[]
-!	[]		[1]
+	[]			[]
+!	[]			[1]
 	[["foo"], ["bar"]]	[qr/o/, qr/a/]
 	["foo", "bar"]		[qr/o/, qr/a/]
 !	["foo", "bar"]		[qr/o/, "foo"]
-	$deep1		$deep1
-!	$deep1		$deep2
+	$deep1			$deep1
+!	$deep1			$deep2
 
-	\@nums		\@tied_nums
+	\@nums			\@tied_nums
 
 #  - a regex
 	[qw(foo bar baz quux)]	qr/x/
diff --git a/t/op/smobj.t b/t/op/smobj.t
deleted file mode 100644
index 9d1a0a5..0000000
--- a/t/op/smobj.t
+++ /dev/null
@@ -1,49 +0,0 @@
-#!./perl
-
-BEGIN {
-    chdir 't';
-    @INC = '../lib';
-    require './test.pl';
-}
-
-plan tests => 11;
-
-use strict;
-use warnings;
-
-
-my @tests = ('$obj ~~ "key"', '"key" ~~ $obj', '$obj ~~ $obj');
-
-{
-    package Test::Object::NoOverload;
-    sub new { bless { key => 1 } }
-}
-
-{
-    my $obj = Test::Object::NoOverload->new;
-    isa_ok($obj, 'Test::Object::NoOverload');
-    for (@tests) {
-	my $r = eval;
-	ok(
-	    ! defined $r,
-	    "we do not smart match against an object's underlying implementation",
-	);
-	like(
-	    $@,
-	    qr/overload/,
-	    "we die when smart matching an obj with no ~~ overload",
-	);
-    }
-}
-
-{
-    package Test::Object::CopyOverload;
-    sub new { bless { key => 1 } }
-    use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
-}
-
-{
-    my $obj = Test::Object::CopyOverload->new;
-    isa_ok($obj, 'Test::Object::CopyOverload');
-    ok(eval, 'we are able to make an object ~~ overload') for @tests;
-}