New tests (and TODO tests) for ~~ and overloading,

based on:

Subject: object ~~ overloading and not
Message-ID: <20080418220238.GA91526@knight.local>

p4raw-id: //depot/perl@33750

diff --git a/MANIFEST b/MANIFEST
index da2b9ac..414dac6 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3970,6 +3970,7 @@ 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/smobj.t b/t/op/smobj.t
new file mode 100644 (file)
index 0000000..733e31c
--- /dev/null
+++ b/t/op/smobj.t
@@ -0,0 +1,48 @@
+#!./perl
+
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan tests => 5;
+
+use strict;
+use warnings;
+
+{
+    package Test::Object::NoOverload;
+    sub new { bless { key => 1 } }
+}
+
+{
+    my $obj = Test::Object::NoOverload->new;
+    isa_ok($obj, 'Test::Object::NoOverload');
+    my $r = eval { ($obj ~~ 'key') };
+
+    local $::TODO = 'To be implemented';
+
+    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($obj ~~ 'key', 'we are able to make an object ~~ overload');
+}