Add Perl_mro_register() to register Method Resolution Orders,

Perl_mro_get_from_name() to retrieve MROs by name, and PL_registered_mros to
store them in. Abolish the static array of mros, and instead register the dfs
and c3 MRO structures.

diff --git a/embed.fnc b/embed.fnc
index bb43543..87f5fd2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2189,6 +2189,8 @@ Aop       |SV*    |mro_get_private_data|NN struct mro_meta *const smeta \
 Aop    |SV*    |mro_set_private_data|NN struct mro_meta *const smeta \
                                     |NN const struct mro_alg *const which \
                                     |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
 : Used in HvMROMETA() in gv.c, pp_hot.c, universal.c
 p      |struct mro_meta*       |mro_meta_init  |NN HV* stash
 #if defined(USE_ITHREADS)

diff --git a/embedvar.h b/embedvar.h
index 0502d00..9ca58c0 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -248,6 +248,7 @@
 #define PL_regex_pad           (vTHX->Iregex_pad)
 #define PL_regex_padav         (vTHX->Iregex_padav)
 #define PL_reginterp_cnt       (vTHX->Ireginterp_cnt)
+#define PL_registered_mros     (vTHX->Iregistered_mros)
 #define PL_regmatch_slab       (vTHX->Iregmatch_slab)
 #define PL_regmatch_state      (vTHX->Iregmatch_state)
 #define PL_rehash_seed         (vTHX->Irehash_seed)
@@ -561,6 +562,7 @@
 #define PL_Iregex_pad          PL_regex_pad
 #define PL_Iregex_padav                PL_regex_padav
 #define PL_Ireginterp_cnt      PL_reginterp_cnt
+#define PL_Iregistered_mros    PL_registered_mros
 #define PL_Iregmatch_slab      PL_regmatch_slab
 #define PL_Iregmatch_state     PL_regmatch_state
 #define PL_Irehash_seed                PL_rehash_seed

diff --git a/global.sym b/global.sym
index af15270..3ac872d 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -771,6 +771,8 @@ Perl_emulate_cop_io
 Perl_get_re_arg
 Perl_mro_get_private_data
 Perl_mro_set_private_data
+Perl_mro_get_from_name
+Perl_mro_register
 Perl_mro_get_linear_isa
 Perl_mro_method_changed_in
 Perl_sys_init

diff --git a/intrpvar.h b/intrpvar.h
index 956b7de..4fa3c0d 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -681,6 +681,12 @@ PERLVARI(Idestroyhook, destroyable_proc_t, MEMBER_TO_FPTR(Perl_sv_destroyable))
 PERLVARI(Isv_serial, U32, 0) /* SV serial number, used in sv.c */
 #endif
 
+/* Register of known Method Resolution Orders.
+   What this actually points to is an implementation detail (it may change to
+   a structure incorporating a reference count - use mro_get_from_name to
+   retrieve a C<struct mro_alg *>  */
+PERLVAR(Iregistered_mros, HV *)
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 

diff --git a/mro.c b/mro.c
index 4ce939b..63ab230 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -35,16 +35,12 @@ struct mro_alg {
     U32 hash; /* or 0 */
 };
 
-/* First one is the default */
-static struct mro_alg mros[] = {
-    {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0},
-    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0}
-};
+static const struct mro_alg dfs_alg =
+    {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
 
-#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
+static const struct mro_alg c3_alg =
+    {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
 
-#define dfs_alg        (&mros[0])
-#define c3_alg (&mros[1])
 
 SV *
 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
@@ -96,16 +92,35 @@ Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
     return data;
 }
 
-static const struct mro_alg *
-S_get_mro_from_name(pTHX_ const char *const name) {
-    const struct mro_alg *algo = mros;
-    const struct mro_alg *const end = mros + NUMBER_OF_MROS;
-    while (algo < end) {
-       if(strEQ(name, algo->name))
-           return algo;
-       ++algo;
+const struct mro_alg *
+Perl_mro_get_from_name(pTHX_ SV *name) {
+    SV **data;
+
+    PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
+
+    data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
+                         HV_FETCH_JUST_SV, NULL, 0);
+    if (!data)
+       return NULL;
+    assert(SvTYPE(*data) == SVt_IV);
+    assert(SvIOK(*data));
+    return INT2PTR(const struct mro_alg *, SvUVX(*data));
+}
+
+void
+Perl_mro_register(pTHX_ const struct mro_alg *mro) {
+    SV *wrapper = newSVuv(PTR2UV(mro));
+
+    PERL_ARGS_ASSERT_MRO_REGISTER;
+
+    
+    if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
+                       mro->name, mro->length, mro->kflags,
+                       HV_FETCH_ISSTORE, wrapper, mro->hash)) {
+       SvREFCNT_dec(wrapper);
+       Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
+                  "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
     }
-    return NULL;
 }
 
 struct mro_meta*
@@ -120,7 +135,7 @@ Perl_mro_meta_init(pTHX_ HV* stash)
     HvAUX(stash)->xhv_mro_meta = newmeta;
     newmeta->cache_gen = 1;
     newmeta->pkg_gen = 1;
-    newmeta->mro_which = mros;
+    newmeta->mro_which = &dfs_alg;
 
     return newmeta;
 }
@@ -231,7 +246,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
     meta = HvMROMETA(stash);
 
     /* return cache if valid */
-    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, dfs_alg)))) {
+    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
         return retval;
     }
 
@@ -337,7 +352,7 @@ S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
        and we do so by replacing it completely */
     SvREADONLY_on(retval);
 
-    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, dfs_alg,
+    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
                                                MUTABLE_SV(retval)));
 }
 
@@ -382,7 +397,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
     meta = HvMROMETA(stash);
 
     /* return cache if valid */
-    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, c3_alg)))) {
+    if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
         return retval;
     }
 
@@ -555,7 +570,7 @@ S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
        and we do so by replacing it completely */
     SvREADONLY_on(retval);
 
-    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, c3_alg,
+    return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
                                                MUTABLE_SV(retval)));
     return retval;
 }
@@ -826,6 +841,9 @@ Perl_boot_core_mro(pTHX)
     dVAR;
     static const char file[] = __FILE__;
 
+    Perl_mro_register(aTHX_ &dfs_alg);
+    Perl_mro_register(aTHX_ &c3_alg);
+
     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
@@ -858,10 +876,9 @@ XS(XS_mro_get_linear_isa) {
         XSRETURN(1);
     }
     else if(items > 1) {
-        const char* const which = SvPV_nolen(ST(1));
-       const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
+       const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
        if (!algo)
-           Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+           Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
        RETVAL = algo->resolve(aTHX_ class_stash, 0);
     }
     else {
@@ -878,7 +895,6 @@ XS(XS_mro_set_mro)
     dVAR;
     dXSARGS;
     SV* classname;
-    const char* whichstr;
     const struct mro_alg *which;
     HV* class_stash;
     struct mro_meta* meta;
@@ -887,14 +903,13 @@ XS(XS_mro_set_mro)
        croak_xs_usage(cv, "classname, type");
 
     classname = ST(0);
-    whichstr = SvPV_nolen(ST(1));
     class_stash = gv_stashsv(classname, GV_ADD);
     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
     meta = HvMROMETA(class_stash);
 
-    which = S_get_mro_from_name(aTHX_ whichstr);
+    which = Perl_mro_get_from_name(aTHX_ ST(1));
     if (!which)
-        Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
+        Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 
     if(meta->mro_which != which) {
         meta->mro_which = which;

diff --git a/perl.c b/perl.c
index 12db1b5..27aff77 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -461,6 +461,8 @@ perl_construct(pTHXx)
     PL_timesbase.tms_cstime = 0;
 #endif
 
+    PL_registered_mros = newHV();
+
     ENTER;
 }
 
@@ -849,6 +851,8 @@ perl_destruct(pTHXx)
     PL_exitlist = NULL;
     PL_exitlistlen = 0;
 
+    SvREFCNT_dec(PL_registered_mros);
+
     /* jettison our possibly duplicated environment */
     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
      * so we certainly shouldn't free it here

diff --git a/perlapi.h b/perlapi.h
index 3eb7124..4f23d25 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -532,6 +532,8 @@ END_EXTERN_C
 #define PL_regex_padav         (*Perl_Iregex_padav_ptr(aTHX))
 #undef  PL_reginterp_cnt
 #define PL_reginterp_cnt       (*Perl_Ireginterp_cnt_ptr(aTHX))
+#undef  PL_registered_mros
+#define PL_registered_mros     (*Perl_Iregistered_mros_ptr(aTHX))
 #undef  PL_regmatch_slab
 #define PL_regmatch_slab       (*Perl_Iregmatch_slab_ptr(aTHX))
 #undef  PL_regmatch_state

diff --git a/proto.h b/proto.h
index f10ce56..244ddc1 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6567,6 +6567,16 @@ PERL_CALLCONV SV*        Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
 #define PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA  \
        assert(smeta); assert(which); assert(data)
 
+PERL_CALLCONV const struct mro_alg *   Perl_mro_get_from_name(pTHX_ SV *name)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_GET_FROM_NAME     \
+       assert(name)
+
+PERL_CALLCONV void     Perl_mro_register(pTHX_ const struct mro_alg *mro)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_MRO_REGISTER  \
+       assert(mro)
+
 PERL_CALLCONV struct mro_meta* Perl_mro_meta_init(pTHX_ HV* stash)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MRO_META_INIT \

diff --git a/sv.c b/sv.c
index a9d9b21..9a5d0e3 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -12174,6 +12174,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
          PTR2UV(PL_watchok));
     }
 
+    PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
+
     if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
         ptr_table_free(PL_ptr_table);
         PL_ptr_table = NULL;