From: Nicholas Clark Date: Fri, 26 Dec 2008 18:26:53 +0000 (+0000) Subject: Add Perl_mro_register() to register Method Resolution Orders, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a3e6e81e81213c31f0612471c427044481a95287;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 */ +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 --- 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 --- 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 --- 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 --- 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 --- 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;