Re: [PATCH] mg_magical() sometimes turns SvRMAGICAL on when it shouldn't

Message-ID: <47ACD61B.6030501@profvince.com>

p4raw-id: //depot/perl@33458

5 files changed, 86 insertions, 11 deletions

diff --git a/MANIFEST b/MANIFEST
index 793653336a..2b9e0f8e6b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1259,6 +1259,7 @@ ext/XS/APItest/t/my_cxt.t	XS::APItest: test MY_CXT interface
 ext/XS/APItest/t/op.t		XS::APItest: tests for OP related APIs
 ext/XS/APItest/t/printf.t	XS::APItest extension
 ext/XS/APItest/t/push.t		XS::APItest extension
+ext/XS/APItest/t/rmagical.t	XS::APItest extension
 ext/XS/APItest/t/svsetsv.t	Test behaviour of sv_setsv with/without PERL_CORE
 ext/XS/APItest/t/xs_special_subs_require.t	for require too
 ext/XS/APItest/t/xs_special_subs.t	Test that XS BEGIN/CHECK/INIT/END work
diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 883a15c8a7..31d5628c09 100644
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -22,9 +22,10 @@ our @EXPORT = qw( print_double print_int print_long
 		  apitest_exception mycroak strtab
 		  my_cxt_getint my_cxt_getsv my_cxt_setint my_cxt_setsv
 		  sv_setsv_cow_hashkey_core sv_setsv_cow_hashkey_notcore
+		  rmagical_cast rmagical_flags
 );
 
-our $VERSION = '0.13';
+our $VERSION = '0.14';
 
 use vars '$WARNINGS_ON_BOOTSTRAP';
 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 4e84816c1d..99af4a0104 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -233,6 +233,13 @@ rot13_key(pTHX_ IV action, SV *field) {
     return 0;
 }
 
+STATIC I32
+rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
+    return 0;
+}
+
+STATIC MGVTBL rmagical_b = { 0 };
+
 #include "const-c.inc"
 
 MODULE = XS::APItest:Hash		PACKAGE = XS::APItest::Hash
@@ -813,6 +820,38 @@ bool
 sv_setsv_cow_hashkey_notcore()
 
 void
+rmagical_cast(sv, type)
+    SV *sv;
+    SV *type;
+    PREINIT:
+	struct ufuncs uf;
+    PPCODE:
+	if (!SvOK(sv) || !SvROK(sv) || !SvOK(type)) { XSRETURN_UNDEF; }
+	sv = SvRV(sv);
+	if (SvTYPE(sv) != SVt_PVHV) { XSRETURN_UNDEF; }
+	uf.uf_val = rmagical_a_dummy;
+	uf.uf_set = NULL;
+	uf.uf_index = 0;
+	if (SvTRUE(type)) { /* b */
+	    sv_magicext(sv, NULL, PERL_MAGIC_ext, &rmagical_b, NULL, 0);
+	} else { /* a */
+	    sv_magic(sv, NULL, PERL_MAGIC_uvar, (char *) &uf, sizeof(uf));
+	}
+	XSRETURN_YES;
+
+void
+rmagical_flags(sv)
+    SV *sv;
+    PPCODE:
+	if (!SvOK(sv) || !SvROK(sv)) { XSRETURN_UNDEF; }
+	sv = SvRV(sv);
+        EXTEND(SP, 3); 
+	mXPUSHu(SvFLAGS(sv) & SVs_GMG);
+	mXPUSHu(SvFLAGS(sv) & SVs_SMG);
+	mXPUSHu(SvFLAGS(sv) & SVs_RMG);
+        XSRETURN(3);
+
+void
 BEGIN()
     CODE:
 	sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
diff --git a/ext/XS/APItest/t/rmagical.t b/ext/XS/APItest/t/rmagical.t
new file mode 100644
index 0000000000..8e1a0a01d3
--- /dev/null
+++ b/ext/XS/APItest/t/rmagical.t
@@ -0,0 +1,29 @@
+#!perl
+
+# Consider two kinds of magic :
+# A : PERL_MAGIC_uvar, with get (but no set) magic
+# B : PERL_MAGIC_ext, with a zero vtbl
+# If those magic are attached on a sv in such a way that the MAGIC chain
+# looks like sv -> B -> A -> NULL (i.e. we first apply A and then B), then
+# mg_magical won't turn SvRMAGICAL on. However, if the chain is in the
+# opposite order (sv -> A -> B -> NULL), SvRMAGICAL used to be turned on.
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+use_ok('XS::APItest');
+
+my (%h1, %h2);
+my @f;
+
+rmagical_cast(\%h1, 0); # A
+rmagical_cast(\%h1, 1); # B
+@f = rmagical_flags(\%h1);
+ok(!$f[2], "For sv -> B -> A -> NULL, SvRMAGICAL(sv) is false");
+
+rmagical_cast(\%h2, 1); # B
+rmagical_cast(\%h2, 0); # A
+@f = rmagical_flags(\%h2);
+ok(!$f[2], "For sv -> A -> B -> NULL, SvRMAGICAL(sv) is false");
diff --git a/mg.c b/mg.c
index 5cfcc463f4..f88b07851b 100644
--- a/mg.c
+++ b/mg.c
@@ -123,16 +123,21 @@ Perl_mg_magical(pTHX_ SV *sv)
     const MAGIC* mg;
     PERL_ARGS_ASSERT_MG_MAGICAL;
     PERL_UNUSED_CONTEXT;
-    for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-	const MGVTBL* const vtbl = mg->mg_virtual;
-	if (vtbl) {
-	    if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
-		SvGMAGICAL_on(sv);
-	    if (vtbl->svt_set)
-		SvSMAGICAL_on(sv);
-	    if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)) || vtbl->svt_clear)
-		SvRMAGICAL_on(sv);
-	}
+    if ((mg = SvMAGIC(sv))) {
+	SvRMAGICAL_off(sv);
+	do {
+	    const MGVTBL* const vtbl = mg->mg_virtual;
+	    if (vtbl) {
+		if (vtbl->svt_get && !(mg->mg_flags & MGf_GSKIP))
+		    SvGMAGICAL_on(sv);
+		if (vtbl->svt_set)
+		    SvSMAGICAL_on(sv);
+		if (vtbl->svt_clear)
+		    SvRMAGICAL_on(sv);
+	    }
+	} while ((mg = mg->mg_moremagic));
+	if (!(SvFLAGS(sv) & (SVs_GMG|SVs_SMG)))
+	    SvRMAGICAL_on(sv);
     }
 }