Add Perl_mro_register() to register Method Resolution Orders,
authorNicholas Clark <nick@ccl4.org>
Fri, 26 Dec 2008 18:26:53 +0000 (18:26 +0000)
committerNicholas Clark <nick@ccl4.org>
Sat, 27 Dec 2008 21:12:12 +0000 (21:12 +0000)
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.

embed.fnc
embedvar.h
global.sym
intrpvar.h
mro.c
perl.c
perlapi.h
proto.h
sv.c

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)
index 0502d00..9ca58c0 100644 (file)
 #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)
 #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
index af15270..3ac872d 100644 (file)
@@ -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
index 956b7de..4fa3c0d 100644 (file)
@@ -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
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;