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

[Rafael Garcia-Suarez]

Change 33785 by [EMAIL PROTECTED] on 2008/05/04 12:46:52

        Subject: Re: [PATCH] ~~ with non-overloaded objects
        From: "Vincent Pit" <[EMAIL PROTECTED]>
        Date: Fri, 2 May 2008 15:03:23 +0200 (CEST)
        Message-ID: <[EMAIL PROTECTED]>
        
        (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.