Break out the set-the-MRO logic from the XS_mro_set_mro into Perl_mro_set_mro(),
authorNicholas Clark <nick@ccl4.org>
Sat, 27 Dec 2008 14:32:59 +0000 (14:32 +0000)
committerDavid Mitchell <davem@iabyn.com>
Mon, 30 Mar 2009 15:42:42 +0000 (16:42 +0100)
which can be called from C code (such as the guts of extensions).

(cherry picked from commit 31b9005d8ff165a414c5e3493027e1656d7e810f)

embed.fnc
global.sym
mro.c
proto.h

index 13cd534..b101c8d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2154,6 +2154,8 @@ Aop       |SV*    |mro_set_private_data|NN struct mro_meta *const smeta \
                                     |NN SV *const data
 Aop    |const struct mro_alg *|mro_get_from_name|NN SV *name
 Aop    |void   |mro_register   |NN const struct mro_alg *mro
+Aop    |void   |mro_set_mro    |NN struct mro_meta *const meta \
+                               |NN SV *const name
 : Used in HvMROMETA(), which is public.
 Xpo    |struct mro_meta*       |mro_meta_init  |NN HV* stash
 #if defined(USE_ITHREADS)
index 4d87c59..4c2980c 100644 (file)
@@ -773,6 +773,7 @@ Perl_mro_get_private_data
 Perl_mro_set_private_data
 Perl_mro_get_from_name
 Perl_mro_register
+Perl_mro_set_mro
 Perl_mro_meta_init
 Perl_mro_get_linear_isa
 Perl_mro_method_changed_in
diff --git a/mro.c b/mro.c
index d40d141..201481b 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -626,6 +626,34 @@ Perl_mro_method_changed_in(pTHX_ HV *stash)
     }
 }
 
+void
+Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
+{
+    const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
+    PERL_ARGS_ASSERT_MRO_SET_MRO;
+
+    if (!which)
+        Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
+
+    if(meta->mro_which != which) {
+       if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
+           /* If we were storing something directly, put it in the hash before
+              we lose it. */
+           Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
+                                     MUTABLE_SV(meta->mro_linear_c3));
+       }
+       meta->mro_which = which;
+       /* Scrub our cached pointer to the private data.  */
+       meta->mro_linear_c3 = NULL;
+        /* Only affects local method cache, not
+           even child classes */
+        meta->cache_gen++;
+        if(meta->mro_nextmethod)
+            hv_clear(meta->mro_nextmethod);
+    }
+}
+
 #include "XSUB.h"
 
 XS(XS_mro_get_linear_isa);
@@ -695,7 +723,6 @@ XS(XS_mro_set_mro)
     dVAR;
     dXSARGS;
     SV* classname;
-    const struct mro_alg *which;
     HV* class_stash;
     struct mro_meta* meta;
 
@@ -707,26 +734,7 @@ XS(XS_mro_set_mro)
     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
     meta = HvMROMETA(class_stash);
 
-    which = Perl_mro_get_from_name(aTHX_ ST(1));
-    if (!which)
-        Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
-
-    if(meta->mro_which != which) {
-       if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
-           /* If we were storing something directly, put it in the hash before
-              we lose it. */
-           Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
-                                     MUTABLE_SV(meta->mro_linear_c3));
-       }
-       meta->mro_which = which;
-       /* Scrub our cached pointer to the private data.  */
-       meta->mro_linear_c3 = NULL;
-        /* Only affects local method cache, not
-           even child classes */
-        meta->cache_gen++;
-        if(meta->mro_nextmethod)
-            hv_clear(meta->mro_nextmethod);
-    }
+    Perl_mro_set_mro(aTHX_ meta, ST(1));
 
     XSRETURN_EMPTY;
 }
diff --git a/proto.h b/proto.h
index 83daccf..7c41b95 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6587,6 +6587,12 @@ PERL_CALLCONV void       Perl_mro_register(pTHX_ const struct mro_alg *mro)
 #define PERL_ARGS_ASSERT_MRO_REGISTER  \
        assert(mro)
 
+PERL_CALLCONV void     Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MRO_SET_MRO   \
+       assert(meta); assert(name)
+
 PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MRO_META_INIT \