Change 33785: Re: [PATCH] ~~ with non-overloaded objects

Change 33785 by rgs@hannibal on 2008/05/04 12:46:52

	Subject: Re: [PATCH] ~~ with non-overloaded objects
	From: "Vincent Pit" <perl@profvince.com>
	Date: Fri, 2 May 2008 15:03:23 +0200 (CEST)
	Message-ID: <62440.92.128.34.102.1209733403.squirrel@92.128.34.102>
	
	(Backport of change #33777 to bleadperl)

Affected files ...

... //depot/maint-5.10/perl/MANIFEST#19 edit
... //depot/maint-5.10/perl/pp_ctl.c#11 edit
... //depot/maint-5.10/perl/t/op/smobj.t#1 add

Differences ...

==== //depot/maint-5.10/perl/MANIFEST#19 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#18~33718~	2008-04-21 16:20:43.000000000 -0700
+++ perl/MANIFEST	2008-05-04 05:46:52.000000000 -0700
@@ -3847,6 +3847,7 @@
 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

==== //depot/maint-5.10/perl/pp_ctl.c#11 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#10~33745~	2008-04-24 20:30:37.000000000 -0700
+++ perl/pp_ctl.c	2008-05-04 05:46:52.000000000 -0700
@@ -3898,6 +3898,13 @@
 	&& (Other = d))	)
 	
 
+#   define SM_OBJECT ( \
+	   (sv_isobject(d) && (!SvMAGICAL(This = SvRV(d))		\
+			    || !mg_find(This, PERL_MAGIC_qr)))		\
+    ||									\
+	   (sv_isobject(e) && (!SvMAGICAL(This = SvRV(e))		\
+			    || !mg_find(This, PERL_MAGIC_qr))) )
+
 #   define SM_OTHER_REF(type) \
 	(SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
 
@@ -3929,6 +3936,9 @@
     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;
 	

==== //depot/maint-5.10/perl/t/op/smobj.t#1 (text) ====
Index: perl/t/op/smobj.t
--- /dev/null	2008-03-18 12:45:05.529577733 -0700
+++ perl/t/op/smobj.t	2008-05-04 05:46:52.000000000 -0700
@@ -0,0 +1,49 @@
+#!./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;
+}
End of Patch.

• Change 33785: Re: [PATCH] ~~ with non-overloaded objects by Rafael Garcia-Suarez