From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date: Fri, 8 May 2009 20:37:03 +0000 (+0200)
Subject: Make ~~ overloading only be invoked on the right argument
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6d743019f3ff1c2efcf74a1e4f98ea5bd3b7351a;p=p5sagit%2Fp5-mst-13.2.git

Make ~~ overloading only be invoked on the right argument
---

diff --git a/pp_ctl.c b/pp_ctl.c
index 5e8d557..c601f7c 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4006,7 +4006,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
 	sv_2mortal(newSViv(PTR2IV(sv))), 0)
 
-    if (SvAMAGIC(d) || SvAMAGIC(e)) {
+    if (SvAMAGIC(e)) {
 	SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
 	if (tmpsv) {
 	    SPAGAIN;
@@ -4039,8 +4039,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 	    RETPUSHYES;
     }
 
-    if ((sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
-	    || (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)))
+    if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP))
 	Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
 
     /* ~~ sub */
diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t
index 3838518..75c0ec0 100644
--- a/t/op/smartmatch.t
+++ b/t/op/smartmatch.t
@@ -150,7 +150,7 @@ __DATA__
 
 # regular object
 @	$obj		$obj
-@	$ov_obj		$obj	TODO
+@	$ov_obj		$obj
 @	\&fatal		$obj
 @	\&FALSE		$obj
 @	\&foo		$obj
diff --git a/t/op/switch.t b/t/op/switch.t
index f4cedba..9ca4f13 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -8,7 +8,7 @@ BEGIN {
 use strict;
 use warnings;
 
-use Test::More tests => 124;
+use Test::More tests => 118;
 
 # The behaviour of the feature pragma should be tested by lib/switch.t
 # using the tests in t/lib/switch/*. This file tests the behaviour of
@@ -772,6 +772,7 @@ SKIP: {
     { package OverloadTest;
 
       use overload '""' => sub{"string value of obj"};
+      use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 
       use overload "~~" => sub {
 	  my ($self, $other, $reversed) = @_;
@@ -806,11 +807,8 @@ SKIP: {
 	    default {$matched = 0}
 	}
     
-	is($obj->{called},  1, "$test: called");
-	ok($matched, "$test: matched");
-	is($obj->{left}, "string value of obj", "$test: left");
-	is($obj->{right}, "other arg", "$test: right");
-	ok(!$obj->{reversed}, "$test: not reversed");
+	is($obj->{called}, 0, "$test: called");
+	ok(!$matched, "$test: not matched");
     }
 
     {
@@ -821,11 +819,8 @@ SKIP: {
 	    when ("other arg") {$matched = 1}
 	}
     
-	is($obj->{called},  1, "$test: called");
+	is($obj->{called}, 0, "$test: called");
 	ok(!$matched, "$test: not matched");
-	is($obj->{left}, "string value of obj", "$test: left");
-	is($obj->{right}, "other arg", "$test: right");
-	ok(!$obj->{reversed}, "$test: not reversed");
     }
 
     {