/* mro.c
*
* Copyright (c) 2007 Brandon L Black
+ * Copyright (c) 2007, 2008 Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
- * You'll be last either way, Master Peregrin."
+ * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
+ * You'll be last either way, Master Peregrin.'
+ *
+ * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
*/
/*
struct mro_alg {
const char *name;
- AV *(*resolve)(pTHX_ HV* stash, I32 level);
+ AV *(*resolve)(pTHX_ HV* stash, U32 level);
};
/* First one is the default */
if (newmeta->mro_linear_dfs)
newmeta->mro_linear_dfs
- = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
+ = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
if (newmeta->mro_linear_c3)
newmeta->mro_linear_c3
- = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
+ = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param)));
if (newmeta->mro_nextmethod)
newmeta->mro_nextmethod
- = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
+ = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
if (newmeta->isa)
newmeta->isa
- = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
+ = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
return newmeta;
}
PERL_ARGS_ASSERT_GET_ISA_HASH;
- if (!meta->isa)
- mro_get_linear_isa_dfs(stash, 0);
- assert(meta->isa);
+ 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;
}
=cut
*/
static AV*
-S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
+S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
AV* retval;
GV** gvp;
/* not in cache, make a new one */
- retval = (AV*)sv_2mortal((SV *)newAV());
+ retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
/* 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);
It's then retained to be re-used as a fast lookup for ->isa(), by adding
our own name and "UNIVERSAL" to it. */
- stored = (HV*)sv_2mortal((SV*)newHV());
+ stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
if(av && AvFILLp(av) >= 0) {
}
}
+ (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. */
SvREFCNT_inc_simple_void_NN(retval);
SvTEMP_off(retval);
- SvREFCNT_inc_simple_void_NN(stored);
- SvTEMP_off(stored);
-
- hv_store_ent(stored, our_name, &PL_sv_undef, 0);
- hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
- SvREADONLY_on(stored);
meta->mro_linear_dfs = retval;
- meta->isa = stored;
return retval;
}
*/
static AV*
-S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
- HV* const tails = (HV*)sv_2mortal((SV*)newHV());
- AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
+ HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
+ AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
- av_push(seqs, (SV*)isa_lin);
+ av_push(seqs, MUTABLE_SV(isa_lin));
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
- av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
+ av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
}
}
- av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
+ av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
- AV* const seq = (AV*)*seqs_ptr++;
+ AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
- AV * const seq = (AV*)(avptr[s]);
+ AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
- SvREFCNT_dec((SV*)meta->mro_linear_dfs);
- SvREFCNT_dec((SV*)meta->mro_linear_c3);
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
+ SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
meta->mro_linear_dfs = NULL;
meta->mro_linear_c3 = NULL;
if (meta->isa) {
is UNIVERSAL or one of its parents */
svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
- isarev = svp ? (HV*)*svp : NULL;
+ isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
- SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
- SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
+ SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
+ SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
revmeta->mro_linear_dfs = NULL;
revmeta->mro_linear_c3 = NULL;
if(!is_universal)
us, then will need to upgrade it to an HV (which sv_upgrade() can
now do for us. */
- mroisarev = (HV*)HeVAL(he);
+ mroisarev = MUTABLE_HV(HeVAL(he));
- SvUPGRADE((SV*)mroisarev, SVt_PVHV);
+ SvUPGRADE(MUTABLE_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
const STRLEN stashname_len = HvNAMELEN_get(stash);
SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
- HV * const isarev = svp ? (HV*)*svp : NULL;
+ HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
/* No stash exists yet, give them just the classname */
AV* isalin = newAV();
av_push(isalin, newSVsv(classname));
- ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
+ ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
XSRETURN(1);
}
else if(items > 1) {
RETVAL = mro_get_linear_isa(class_stash);
}
- ST(0) = newRV_inc((SV*)RETVAL);
+ ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
sv_2mortal(ST(0));
XSRETURN(1);
}
he = hv_fetch_ent(PL_isarev, classname, 0, 0);
- isarev = he ? (HV*)HeVAL(he) : NULL;
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
ret_array = newAV();
if(isarev) {
while((iter = hv_iternext(isarev)))
av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
}
- mXPUSHs(newRV_noinc((SV*)ret_array));
+ mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
PUTBACK;
return;
classname_pv = SvPV(classname,classname_len);
he = hv_fetch_ent(PL_isarev, classname, 0, 0);
- isarev = he ? (HV*)HeVAL(he) : NULL;
+ isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
entries, because in C3 the method cache of a parent is not
valid for the child */
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);
- mXPUSHs(newRV_inc((SV*)cand_cv));
+ SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
+ (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
+ mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
XSRETURN(1);
}
}
https://perl5.git.perl.org / perl5.git / blobdiff