From: Vincent Pit <perl@profvince.com>
Date: Thu, 1 May 2008 12:45:51 +0000 (+0200)
Subject: ~~ with non-overloaded objects
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e67b97bd974194ad616acbb7813c5631aacd6be7;p=p5sagit%2Fp5-mst-13.2.git

~~ with non-overloaded objects
From: "Vincent Pit" <perl@profvince.com>
Message-ID: <63496.92.128.104.139.1209638751.squirrel@92.128.104.139>

p4raw-id: //depot/perl@33777
---

diff --git a/pp_ctl.c b/pp_ctl.c
index 08c6d70..261b1be 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4012,6 +4012,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	&& (Other = d))	)
 	
 
+#   define SM_OBJECT ( \
+	   (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))		\
+    ||									\
+	   (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )	\
+
 #   define SM_OTHER_REF(type) \
 	(SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
 
@@ -4043,6 +4048,9 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     if (SvGMAGICAL(e))
 	e = sv_mortalcopy(e);
 
+    if (SM_OBJECT)
+	Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+
     if (SM_CV_NEP) {
 	I32 c;
 	
diff --git a/t/op/smobj.t b/t/op/smobj.t
index 733e31c..9d1a0a5 100644
--- a/t/op/smobj.t
+++ b/t/op/smobj.t
@@ -6,11 +6,14 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5;
+plan tests => 11;
 
 use strict;
 use warnings;
 
+
+my @tests = ('$obj ~~ "key"', '"key" ~~ $obj', '$obj ~~ $obj');
+
 {
     package Test::Object::NoOverload;
     sub new { bless { key => 1 } }
@@ -19,20 +22,18 @@ use warnings;
 {
     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",
-    );
+    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",
+	);
+    }
 }
 
 {
@@ -44,5 +45,5 @@ use warnings;
 {
     my $obj = Test::Object::CopyOverload->new;
     isa_ok($obj, 'Test::Object::CopyOverload');
-    ok($obj ~~ 'key', 'we are able to make an object ~~ overload');
+    ok(eval, 'we are able to make an object ~~ overload') for @tests;
 }