From 31b9005d8ff165a414c5e3493027e1656d7e810f Mon Sep 17 00:00:00 2001
From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 27 Dec 2008 14:32:59 +0000
Subject: [PATCH] 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).

---
 embed.fnc  |  2 ++
 global.sym |  1 +
 mro.c      | 50 +++++++++++++++++++++++++++++---------------------
 proto.h    |  6 ++++++
 4 files changed, 38 insertions(+), 21 deletions(-)

diff --git a/embed.fnc b/embed.fnc
index 35e80ec..c76ca9d 100644
--- 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
--- 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
--- 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
--- 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	\
-- 
2.7.4