Break out the set-the-MRO logic from the XS_mro_set_mro into Perl_mro_set_mro(),

which can be called from C code (such as the guts of extensions).

diff --git a/embed.fnc b/embed.fnc
index 35e80ec..c76ca9d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2191,6 +2191,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)

diff --git a/global.sym b/global.sym
index 2745823..5ec7ba3 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -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 ba7883c..dadfe3d 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -619,6 +619,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);
@@ -688,7 +716,6 @@ XS(XS_mro_set_mro)
     dVAR;
     dXSARGS;
     SV* classname;
-    const struct mro_alg *which;
     HV* class_stash;
     struct mro_meta* meta;
 
@@ -700,26 +727,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 87e1e86..1313b31 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6577,6 +6577,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 \