*/
#include "EXTERN.h"
+#define PERL_IN_MRO_C
#include "perl.h"
+struct mro_alg {
+ const char *name;
+ AV *(*resolve)(pTHX_ HV* stash, I32 level);
+};
+
+/* First one is the default */
+static struct mro_alg mros[] = {
+ {"dfs", S_mro_get_linear_isa_dfs},
+ {"c3", S_mro_get_linear_isa_c3}
+};
+
+#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
+
+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;
+ }
+ return NULL;
+}
+
struct mro_meta*
Perl_mro_meta_init(pTHX_ HV* stash)
{
struct mro_meta* newmeta;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_META_INIT;
assert(HvAUX(stash));
assert(!(HvAUX(stash)->xhv_mro_meta));
Newxz(newmeta, 1, struct mro_meta);
HvAUX(stash)->xhv_mro_meta = newmeta;
newmeta->cache_gen = 1;
newmeta->pkg_gen = 1;
+ newmeta->mro_which = mros;
return newmeta;
}
{
struct mro_meta* newmeta;
- assert(smeta);
+ PERL_ARGS_ASSERT_MRO_META_DUP;
Newx(newmeta, 1, struct mro_meta);
Copy(smeta, newmeta, 1, struct mro_meta);
=cut
*/
-AV*
-Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
+static AV*
+S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
{
AV* retval;
- AV* tmp_retval; /* mortal to avoid leaks */
GV** gvp;
GV* gv;
AV* av;
- const char* stashname;
+ const HEK* stashhek;
struct mro_meta* meta;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert(HvAUX(stash));
- stashname = HvNAME_get(stash);
- if (!stashname)
+ stashhek = HvNAME_HEK(stash);
+ if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
- stashname);
+ HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* not in cache, make a new one */
- tmp_retval = (AV*)sv_2mortal((SV*)newAV());
- av_push(tmp_retval, newSVpv(stashname, 0)); /* add ourselves at the top */
+ retval = (AV*)sv_2mortal((SV *)newAV());
+ av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
else {
/* otherwise, recurse into ourselves for the MRO
of this @ISA member, and append their MRO to ours.
- The recursive call could throw an exception, which
- has memory management implications here (tmp_retval) */
+ The recursive call could throw an exception, which
+ has memory management implications here, hence the use of
+ the mortal. */
const AV *const subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
}
while(subrv_items--) {
SV *const subsv = *subrv_p++;
- if(!hv_exists_ent(stored, subsv, 0)) {
- hv_store_ent(stored, subsv, &PL_sv_undef, 0);
- av_push(tmp_retval, newSVsv(subsv));
+ /* LVALUE fetch will create a new undefined SV if necessary
+ */
+ HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
+ assert(he);
+ if(HeVAL(he) != &PL_sv_undef) {
+ /* It was newly created. Steal it for our new SV, and
+ replace it in the hash with the "real" thing. */
+ SV *const val = HeVAL(he);
+ HEK *const key = HeKEY_hek(he);
+
+ HeVAL(he) = &PL_sv_undef;
+ /* Save copying by making a shared hash key scalar. We
+ inline this here rather than calling Perl_newSVpvn_share
+ because we already have the scalar, and we already have
+ the hash key. */
+ assert(SvTYPE(val) == SVt_NULL);
+ sv_upgrade(val, SVt_PV);
+ SvPV_set(val, HEK_KEY(share_hek_hek(key)));
+ SvCUR_set(val, HEK_LEN(key));
+ SvREADONLY_on(val);
+ SvFAKE_on(val);
+ SvPOK_on(val);
+ if (HEK_UTF8(key))
+ SvUTF8_on(val);
+
+ av_push(retval, val);
}
}
}
}
- /* make the real retval out of tmp_retval, now that we're
- past the exception dangers */
- retval = av_make(AvFILLp(tmp_retval)+1, AvARRAY(tmp_retval));
+ /* now that we're past the exception dangers, grab our own reference to
+ the AV we're about to use for the result. The reference owned by the
+ mortals' stack will be released soon, so everything will balance. */
+ SvREFCNT_inc_simple_void_NN(retval);
+ SvTEMP_off(retval);
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
=cut
*/
-AV*
-Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+static AV*
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
- const char* stashname;
- STRLEN stashname_len;
+ const HEK* stashhek;
struct mro_meta* meta;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
- stashname = HvNAME_get(stash);
- stashname_len = HvNAMELEN_get(stash);
- if (!stashname)
+ stashhek = HvNAME_HEK(stash);
+ if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
- stashname);
+ HEK_KEY(stashhek));
meta = HvMROMETA(stash);
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
- HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
- if(!he) {
- hv_store_ent(tails, seqitem, newSViv(1), 0);
- }
- else {
+ /* LVALUE fetch will create a new undefined SV if necessary
+ */
+ HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
+ if(he) {
SV* const val = HeVAL(he);
+ /* This will increment undef to 1, which is what we
+ want for a newly created entry. */
sv_inc(val);
}
}
/* Initialize retval to build the return value in */
retval = newAV();
- av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
+ av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
Safefree(heads);
Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
- "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
+ "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
- av_push(retval, newSVpvn(stashname, stashname_len));
+ av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
{
struct mro_meta* meta;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
if(!SvOOK(stash))
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
meta = HvMROMETA(stash);
- if(meta->mro_which == MRO_DFS) {
- return mro_get_linear_isa_dfs(stash, 0);
- } else if(meta->mro_which == MRO_C3) {
- return mro_get_linear_isa_c3(stash, 0);
- } else {
+ if (!meta->mro_which)
Perl_croak(aTHX_ "panic: invalid MRO!");
- }
- return NULL; /* NOT REACHED */
+ return meta->mro_which->resolve(aTHX_ stash, 0);
}
/*
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
+ PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
+
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- SV* const revkey = hv_iterkeysv(iter);
- HV* revstash = gv_stashsv(revkey, 0);
+ I32 len;
+ const char* const revkey = hv_iterkey(iter, &len);
+ HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
SV* const sv = *svp++;
HV* mroisarev;
- HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
- if(!he) {
- he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
- }
+ HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
+
+ /* That fetch should not fail. But if it had to create a new SV for
+ us, then will need to upgrade it to an HV (which sv_upgrade() can
+ now do for us. */
+
mroisarev = (HV*)HeVAL(he);
+ SvUPGRADE((SV*)mroisarev, SVt_PVHV);
+
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
- hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+ (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 revkeylen;
char* const revkey = hv_iterkey(iter, &revkeylen);
- hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
+ (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
}
}
SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
HV * const isarev = svp ? (HV*)*svp : NULL;
+ PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
+
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- SV* const revkey = hv_iterkeysv(iter);
- HV* const revstash = gv_stashsv(revkey, 0);
+ I32 len;
+ const char* const revkey = hv_iterkey(iter, &len);
+ HV* const revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* mrometa;
if(!revstash) continue;
HV* class_stash;
SV* classname;
- PERL_UNUSED_ARG(cv);
-
if(items < 1 || items > 2)
- Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
+ croak_xs_usage(cv, "classname [, type ]");
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
}
else if(items > 1) {
const char* const which = SvPV_nolen(ST(1));
- if(strEQ(which, "dfs"))
- RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
- else if(strEQ(which, "c3"))
- RETVAL = mro_get_linear_isa_c3(class_stash, 0);
- else
- Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+ const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
+ if (!algo)
+ Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
+ RETVAL = algo->resolve(aTHX_ class_stash, 0);
}
else {
RETVAL = mro_get_linear_isa(class_stash);
dVAR;
dXSARGS;
SV* classname;
- char* whichstr;
- mro_alg which;
+ const char* whichstr;
+ const struct mro_alg *which;
HV* class_stash;
struct mro_meta* meta;
- PERL_UNUSED_ARG(cv);
-
if (items != 2)
- Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
+ croak_xs_usage(cv, "classname, type");
classname = ST(0);
whichstr = SvPV_nolen(ST(1));
if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
meta = HvMROMETA(class_stash);
- if(strEQ(whichstr, "dfs"))
- which = MRO_DFS;
- else if(strEQ(whichstr, "c3"))
- which = MRO_C3;
- else
+ which = S_get_mro_from_name(aTHX_ whichstr);
+ if (!which)
Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
if(meta->mro_which != which) {
SV* classname;
HV* class_stash;
- PERL_UNUSED_ARG(cv);
-
if (items != 1)
- Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
- if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
- ST(0) = sv_2mortal(newSVpvn("dfs", 3));
- else
- ST(0) = sv_2mortal(newSVpvn("c3", 2));
-
+ ST(0) = sv_2mortal(newSVpv(class_stash
+ ? HvMROMETA(class_stash)->mro_which->name
+ : "dfs", 0));
XSRETURN(1);
}
dVAR;
dXSARGS;
SV* classname;
- SV** svp;
+ HE* he;
HV* isarev;
- char* classname_pv;
- STRLEN classname_len;
AV* ret_array;
- PERL_UNUSED_ARG(cv);
-
if (items != 1)
- Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
SP -= items;
- classname_pv = SvPV_nolen(classname);
- classname_len = strlen(classname_pv);
- svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
- isarev = svp ? (HV*)*svp : NULL;
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? (HV*)HeVAL(he) : NULL;
ret_array = newAV();
if(isarev) {
while((iter = hv_iternext(isarev)))
av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
}
- XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
+ mXPUSHs(newRV_noinc((SV*)ret_array));
PUTBACK;
return;
HV* isarev;
char* classname_pv;
STRLEN classname_len;
- SV** svp;
-
- PERL_UNUSED_ARG(cv);
+ HE* he;
if (items != 1)
- Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
- classname_pv = SvPV_nolen(classname);
- classname_len = strlen(classname_pv);
+ classname_pv = SvPV(classname,classname_len);
- svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
- isarev = svp ? (HV*)*svp : NULL;
+ he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+ isarev = he ? (HV*)HeVAL(he) : NULL;
if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
dVAR;
dXSARGS;
- PERL_UNUSED_ARG(cv);
-
if (items != 0)
- Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
+ croak_xs_usage(cv, "");
PL_sub_generation++;
SV* classname;
HV* class_stash;
- PERL_UNUSED_ARG(cv);
-
if(items != 1)
- Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
SV* classname;
HV* class_stash;
- PERL_UNUSED_ARG(cv);
-
if(items != 1)
- Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
SP -= items;
- XPUSHs(sv_2mortal(newSViv(
- class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
- )));
+ mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
PUTBACK;
return;
if(sv_isobject(self))
selfstash = SvSTASH(SvRV(self));
else
- selfstash = gv_stashsv(self, 0);
+ selfstash = gv_stashsv(self, GV_ADD);
assert(selfstash);
Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
XSRETURN_EMPTY;
}
- XPUSHs(sv_2mortal(newRV_inc(val)));
+ mXPUSHs(newRV_inc(val));
XSRETURN(1);
}
}
/* beyond here is just for cache misses, so perf isn't as critical */
stashname_len = subname - fq_subname - 2;
- stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
+ stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
valid for the child */
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
- hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
- XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+ (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+ mXPUSHs(newRV_inc((SV*)cand_cv));
XSRETURN(1);
}
}
}
- hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
+ (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
if(throw_nomethod)
Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
XSRETURN_EMPTY;
projects / p5sagit/p5-mst-13.2.git / blobdiff