{
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);
{
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);
if (newmeta->mro_nextmethod)
newmeta->mro_nextmethod
= (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
+ if (newmeta->isa)
+ newmeta->isa
+ = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
return newmeta;
}
#endif /* USE_ITHREADS */
+HV *
+Perl_get_isa_hash(pTHX_ HV *const stash)
+{
+ dVAR;
+ struct mro_meta *const meta = HvMROMETA(stash);
+
+ PERL_ARGS_ASSERT_GET_ISA_HASH;
+
+ if (!meta->isa) {
+ AV *const isa = mro_get_linear_isa(stash);
+ if (!meta->isa) {
+ HV *const isa_hash = newHV();
+ /* Linearisation didn't build it for us, so do it here. */
+ SV *const *svp = AvARRAY(isa);
+ SV *const *const svp_end = svp + AvFILLp(isa) + 1;
+ const HEK *const canon_name = HvNAME_HEK(stash);
+
+ while (svp < svp_end) {
+ (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
+ }
+
+ (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
+ HEK_LEN(canon_name), HEK_FLAGS(canon_name),
+ HV_FETCH_ISSTORE, &PL_sv_undef,
+ HEK_HASH(canon_name));
+ (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
+
+ SvREADONLY_on(isa_hash);
+
+ meta->isa = isa_hash;
+ }
+ }
+ return meta->isa;
+}
+
/*
=for apidoc mro_get_linear_isa_dfs
AV* av;
const HEK* stashhek;
struct mro_meta* meta;
+ SV *our_name;
+ HV *stored;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
/* not in cache, make a new one */
retval = (AV*)sv_2mortal((SV *)newAV());
- av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
+ /* We use this later in this function, but don't need a reference to it
+ beyond the end of this function, so reference count is fine. */
+ our_name = newSVhek(stashhek);
+ av_push(retval, our_name); /* add ourselves at the top */
/* fetch our @ISA */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
- if(av && AvFILLp(av) >= 0) {
+ /* "stored" is used to keep track of all of the classnames we have added to
+ the MRO so far, so we can do a quick exists check and avoid adding
+ duplicate classnames to the MRO as we go.
+ It's then retained to be re-used as a fast lookup for ->isa(), by adding
+ our own name and "UNIVERSAL" to it. */
- /* "stored" is used to keep track of all of the classnames
- we have added to the MRO so far, so we can do a quick
- exists check and avoid adding duplicate classnames to
- the MRO as we go. */
+ stored = (HV*)sv_2mortal((SV*)newHV());
+
+ if(av && AvFILLp(av) >= 0) {
- HV* const stored = (HV*)sv_2mortal((SV*)newHV());
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
}
while(subrv_items--) {
SV *const subsv = *subrv_p++;
- if(!hv_exists_ent(stored, subsv, 0)) {
- (void)hv_store_ent(stored, subsv, &PL_sv_undef, 0);
- av_push(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);
}
}
}
}
+ (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
+ (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
+
+ SvREFCNT_inc_simple_void_NN(stored);
+ SvTEMP_off(stored);
+ SvREADONLY_on(stored);
+
+ meta->isa = stored;
+
/* 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. */
const HEK* stashhek;
struct mro_meta* meta;
- assert(stash);
+ PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
{
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");
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");
SvREFCNT_dec((SV*)meta->mro_linear_c3);
meta->mro_linear_dfs = NULL;
meta->mro_linear_c3 = NULL;
+ if (meta->isa) {
+ SvREFCNT_dec(meta->isa);
+ meta->isa = NULL;
+ }
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
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
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);
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));
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);
HV* isarev;
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);
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;
STRLEN classname_len;
HE* he;
- PERL_UNUSED_ARG(cv);
-
if (items != 1)
- Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
+ croak_xs_usage(cv, "classname");
classname = ST(0);
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 */
if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
(void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
- XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
+ mXPUSHs(newRV_inc((SV*)cand_cv));
XSRETURN(1);
}
}
projects / p5sagit/p5-mst-13.2.git / blobdiff