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

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

p4raw-id: //depot/perl@33458

diff --git a/MANIFEST b/MANIFEST
index 7936533..2b9e0f8 100644 (file)
--- 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 883a15c..31d5628 100644 (file)
--- 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 4e84816..99af4a0 100644 (file)
--- 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 (file)
index 0000000..8e1a0a0
--- /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 5cfcc46..f88b078 100644 (file)
--- 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);
     }
 }