#include "EXTERN.h"
#define PERL_IN_MRO_C
#define PERL_IN_MRO_CORE_C
#include "perl.h"
static
const
struct
mro_alg dfs_alg =
{S_mro_get_linear_isa_dfs,
"dfs"
, 3, 0, 0};
SV *
Perl_mro_get_private_data(pTHX_
struct
mro_meta *
const
smeta,
const
struct
mro_alg *
const
which)
{
SV **data;
PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
which->name, which->length, which->kflags,
HV_FETCH_JUST_SV, NULL, which->hash);
if
(!data)
return
NULL;
if
(smeta->mro_which == which)
smeta->mro_linear_current = *data;
return
*data;
}
SV *
Perl_mro_set_private_data(pTHX_
struct
mro_meta *
const
smeta,
const
struct
mro_alg *
const
which, SV *
const
data)
{
PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
if
(!smeta->mro_linear_all) {
if
(smeta->mro_which == which) {
smeta->mro_linear_current = data;
return
data;
}
else
{
HV *
const
hv = newHV();
HvMAX(hv) = 1;
smeta->mro_linear_all = hv;
if
(smeta->mro_linear_current) {
Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
smeta->mro_linear_current);
}
}
}
if
(smeta->mro_which == which) {
smeta->mro_linear_current = data;
}
if
(!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
which->name, which->length, which->kflags,
HV_FETCH_ISSTORE, data, which->hash)) {
Perl_croak(aTHX_
"panic: hv_store() failed in set_mro_private_data() "
"for '%.*s' %d"
, (
int
) which->length, which->name,
which->kflags);
}
return
data;
}
const
struct
mro_alg *
Perl_mro_get_from_name(pTHX_ SV *name) {
SV **data;
PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
data = (SV **)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_NN(wrapper);
Perl_croak(aTHX_
"panic: hv_store() failed in mro_register() "
"for '%.*s' %d"
, (
int
) mro->length, mro->name, mro->kflags);
}
}
struct
mro_meta*
Perl_mro_meta_init(pTHX_ HV* stash)
{
struct
mro_meta* newmeta;
PERL_ARGS_ASSERT_MRO_META_INIT;
PERL_UNUSED_CONTEXT;
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 = &dfs_alg;
return
newmeta;
}
#if defined(USE_ITHREADS)
struct
mro_meta*
Perl_mro_meta_dup(pTHX_
struct
mro_meta* smeta, CLONE_PARAMS* param)
{
struct
mro_meta* newmeta;
PERL_ARGS_ASSERT_MRO_META_DUP;
Newx(newmeta, 1,
struct
mro_meta);
Copy(smeta, newmeta, 1,
struct
mro_meta);
if
(newmeta->mro_linear_all) {
newmeta->mro_linear_all
= MUTABLE_HV(sv_dup_inc((
const
SV *)newmeta->mro_linear_all, param));
newmeta->mro_linear_current = NULL;
}
else
if
(newmeta->mro_linear_current) {
newmeta->mro_linear_current
= sv_dup_inc((
const
SV *)newmeta->mro_linear_current, param);
}
if
(newmeta->mro_nextmethod)
newmeta->mro_nextmethod
= MUTABLE_HV(sv_dup_inc((
const
SV *)newmeta->mro_nextmethod, param));
if
(newmeta->isa)
newmeta->isa
= MUTABLE_HV(sv_dup_inc((
const
SV *)newmeta->isa, param));
newmeta->super = NULL;
newmeta->destroy = NULL;
newmeta->destroy_gen = 0;
return
newmeta;
}
#endif /* USE_ITHREADS */
static
AV*
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* av;
const
HEK* stashhek;
struct
mro_meta* meta;
SV *our_name;
HV *stored = NULL;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert
(HvAUX(stash));
stashhek
= HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
? HvENAME_HEK_NN(stash)
: 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 '%"
HEKf
"'"
,
HEKfARG(stashhek));
meta = HvMROMETA(stash);
if
((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return
retval;
}
retval = newAV_mortal();
our_name = newSVhek(stashhek);
av_push_simple(retval, our_name);
gvp = (GV**)hv_fetchs(stash,
"ISA"
, FALSE);
av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if
(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
while
(items--) {
SV*
const
sv = *svp ? *svp : &PL_sv_undef;
HV*
const
basestash = gv_stashsv(sv, 0);
SV *
const
*subrv_p;
I32 subrv_items;
svp++;
if
(!basestash) {
subrv_p = &sv;
subrv_items = 1;
}
else
{
const
AV *
const
subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
if
(stored) {
while
(subrv_items--) {
SV *
const
subsv = *subrv_p++;
HE *
const
he = hv_fetch_ent(stored, subsv, 1, 0);
assert
(he);
if
(HeVAL(he) != &PL_sv_undef) {
SV *
const
val = HeVAL(he);
HEK *
const
key = HeKEY_hek(he);
HeVAL(he) = &PL_sv_undef;
sv_sethek(val, key);
av_push_simple(retval, val);
}
}
}
else
{
if
(basestash) {
SV **svp;
stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
av_extend(retval, subrv_items);
AvFILLp(retval) = subrv_items;
svp = AvARRAY(retval);
while
(subrv_items--) {
SV *
const
val = *subrv_p++;
*++svp = SvIsCOW_shared_hash(val)
? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
: newSVsv(val);
}
}
else
{
stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV));
(
void
) hv_stores(stored,
"UNIVERSAL"
, &PL_sv_undef);
av_push_simple(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
}
}
}
}
else
{
stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV));
(
void
) hv_stores(stored,
"UNIVERSAL"
, &PL_sv_undef);
}
(
void
) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
SvREFCNT_inc_simple_void_NN(stored);
SvTEMP_off(stored);
SvREADONLY_on(stored);
meta->isa = stored;
SvREFCNT_inc_simple_void_NN(retval);
SvTEMP_off(retval);
SvREADONLY_on(retval);
return
MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}
AV*
Perl_mro_get_linear_isa(pTHX_ HV *stash)
{
struct
mro_meta* meta;
AV *isa;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
if
(!HvHasAUX(stash))
Perl_croak(aTHX_
"Can't linearize anonymous symbol table"
);
meta = HvMROMETA(stash);
if
(!meta->mro_which)
Perl_croak(aTHX_
"panic: invalid MRO!"
);
isa = meta->mro_which->resolve(aTHX_ stash, 0);
if
(meta->mro_which != &dfs_alg) {
SV *
const
namesv =
(HvHasENAME_HEK(stash) || HvHasNAME(stash))
? newSVhek(HvHasENAME_HEK(stash)
? HvENAME_HEK(stash)
: HvNAME_HEK(stash))
: NULL;
if
(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
{
AV *
const
old = isa;
SV **svp;
SV **ovp = AvARRAY(old);
SV *
const
*
const
oend = ovp + AvFILLp(old) + 1;
isa = (AV *)newSV_type_mortal(SVt_PVAV);
av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
*AvARRAY(isa) = namesv;
svp = AvARRAY(isa)+1;
while
(ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
}
else
SvREFCNT_dec(namesv);
}
if
(!meta->isa) {
HV *
const
isa_hash = newHV();
I32 count = AvFILLp(isa) + 1;
SV *
const
*svp = AvARRAY(isa);
SV *
const
*
const
svp_end = svp + count;
const
HEK *canon_name = HvENAME_HEK(stash);
if
(!canon_name) canon_name = HvNAME_HEK(stash);
if
(count > PERL_HASH_DEFAULT_HvMAX) {
hv_ksplit(isa_hash, count);
}
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_stores(isa_hash,
"UNIVERSAL"
, &PL_sv_undef);
SvREADONLY_on(isa_hash);
meta->isa = isa_hash;
}
return
isa;
}
#define CLEAR_LINEAR(mEta) \
if
(mEta->mro_linear_all) { \
SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
mEta->mro_linear_all = NULL; \
\
mEta->mro_linear_current = NULL; \
}
else
if
(mEta->mro_linear_current) { \
\
SvREFCNT_dec(mEta->mro_linear_current); \
mEta->mro_linear_current = NULL; \
}
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool
is_universal;
struct
mro_meta * meta;
HV *isa = NULL;
const
HEK *
const
stashhek = HvENAME_HEK(stash);
const
char
*
const
stashname = HvENAME_get(stash);
const
STRLEN stashname_len = HvENAMELEN_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"
);
meta = HvMROMETA(stash);
CLEAR_LINEAR(meta);
if
(meta->isa) {
isa = (HV *)sv_2mortal((SV *)meta->isa);
meta->isa = NULL;
}
meta->pkg_gen++;
svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if
((memEQs(stashname, stashname_len,
"UNIVERSAL"
))
|| (isarev && hv_existss(isarev,
"UNIVERSAL"
))) {
PL_sub_generation++;
is_universal = TRUE;
}
else
{
meta->cache_gen++;
is_universal = FALSE;
}
if
(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
HvAMAGIC_on(stash);
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
meta->destroy_gen = 0;
if
(isarev) {
HV *isa_hashes = NULL;
if
(hv_iterinit(isarev)) {
isa_hashes = (HV *)newSV_type_mortal(SVt_PVHV);
}
while
((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct
mro_meta* revmeta;
if
(!revstash)
continue
;
revmeta = HvMROMETA(revstash);
CLEAR_LINEAR(revmeta);
if
(!is_universal)
revmeta->cache_gen++;
if
(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if
(!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
(
void
)
hv_store(
isa_hashes, (
const
char
*)&revstash,
sizeof
(HV *),
revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
);
revmeta->isa = NULL;
}
SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
if
(isa_hashes) {
hv_iterinit(isa_hashes);
while
((iter = hv_iternext(isa_hashes))) {
HV*
const
revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
HV *
const
isa = (HV *)HeVAL(iter);
const
HEK *namehek;
linear_mro = mro_get_linear_isa(revstash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
namehek = HvENAME_HEK(revstash);
if
(!namehek) namehek = HvNAME_HEK(revstash);
while
(items--) {
SV*
const
sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
(
void
)
hv_storehek(mroisarev, namehek, &PL_sv_yes);
}
if
((SV *)isa != &PL_sv_undef && HvTOTALKEYS(isa)) {
assert
(namehek);
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
HvMROMETA(revstash)->isa, HEK_HASH(namehek),
HEK_UTF8(namehek)
);
}
}
}
}
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while
(items--) {
SV*
const
sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
(
void
)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
}
if
(isa && HvTOTALKEYS(isa))
mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
HEK_HASH(stashhek), HEK_UTF8(stashhek));
}
STATIC
void
S_mro_clean_isarev(pTHX_ HV *
const
isa,
const
char
*
const
name,
const
STRLEN len, HV *
const
exceptions, U32 hash,
U32 flags)
{
HE* iter;
PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
assert
(HvTOTALKEYS(isa));
hv_iterinit(isa);
while
((iter = hv_iternext(isa))) {
SV **svp;
HEK *key = HeKEY_hek(iter);
if
(exceptions && hv_existshek(exceptions, key))
continue
;
svp = hv_fetchhek(PL_isarev, key, 0);
if
(svp) {
HV *
const
isarev = (HV *)*svp;
(
void
)hv_common(isarev, NULL, name, len, flags,
G_DISCARD|HV_DELETE, NULL, hash);
if
(!HvTOTALKEYS(isarev))
(
void
)hv_deletehek(PL_isarev, key, G_DISCARD);
}
}
}
void
Perl_mro_package_moved(pTHX_ HV *
const
stash, HV *
const
oldstash,
const
GV *
const
gv, U32 flags)
{
SV *namesv;
HEK **namep;
I32 name_count;
HV *stashes;
HE* iter;
PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
assert
(stash || oldstash);
if
(!(flags & 1)) {
SV **svp;
if
(
!GvSTASH(gv) || !HvHasENAME(GvSTASH(gv)) ||
!(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
*svp != (SV *)gv
)
return
;
}
assert
(HvHasAUX(GvSTASH(gv)));
assert
(GvNAMELEN(gv));
assert
(GvNAME(gv)[GvNAMELEN(gv) - 1] ==
':'
);
assert
(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] ==
':'
);
name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
if
(!name_count) {
name_count = 1;
namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
}
else
{
namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
if
(name_count < 0) ++namep, name_count = -name_count - 1;
}
if
(name_count == 1) {
if
(memEQs(HEK_KEY(*namep), HEK_LEN(*namep),
"main"
)) {
namesv = GvNAMELEN(gv) == 1
? newSVpvs_flags(
":"
, SVs_TEMP)
: newSVpvs_flags(
""
, SVs_TEMP);
}
else
{
namesv = newSVhek_mortal(*namep);
if
(GvNAMELEN(gv) == 1) sv_catpvs(namesv,
":"
);
else
sv_catpvs(namesv,
"::"
);
}
if
(GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
else
{
SV *aname;
namesv = newSV_type_mortal(SVt_PVAV);
while
(name_count--) {
if
(memEQs(HEK_KEY(*namep), HEK_LEN(*namep),
"main"
)){
aname = GvNAMELEN(gv) == 1
? newSVpvs(
":"
)
: newSVpvs(
""
);
namep++;
}
else
{
aname = newSVhek(*namep++);
if
(GvNAMELEN(gv) == 1) sv_catpvs(aname,
":"
);
else
sv_catpvs(aname,
"::"
);
}
if
(GvNAMELEN(gv) != 1) {
sv_catpvn_flags(
aname, GvNAME(gv), GvNAMELEN(gv) - 2,
GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
);
}
av_push_simple((AV *)namesv, aname);
}
}
stashes = (HV *) newSV_type_mortal(SVt_PVHV);
mro_gather_and_rename(
stashes, (HV *) newSV_type_mortal(SVt_PVHV),
stash, oldstash, namesv
);
hv_iterinit(stashes);
while
((iter = hv_iternext(stashes))) {
HV *
const
this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
if
(HvENAME(this_stash)) {
struct
mro_meta *
const
meta = HvMROMETA(this_stash);
if
(meta->isa != (HV *)HeVAL(iter)){
SvREFCNT_dec(meta->isa);
meta->isa
= HeVAL(iter) == &PL_sv_yes
? NULL
: (HV *)HeVAL(iter);
HeVAL(iter) = NULL;
}
mro_isa_changed_in(this_stash);
}
}
}
STATIC
void
S_mro_gather_and_rename(pTHX_ HV *
const
stashes, HV *
const
seen_stashes,
HV *stash, HV *oldstash, SV *namesv)
{
XPVHV* xhv;
HE *entry;
I32 riter = -1;
I32 items = 0;
const
bool
stash_had_name = stash && HvHasENAME(stash);
bool
fetched_isarev = FALSE;
HV *seen = NULL;
HV *isarev = NULL;
SV **svp = NULL;
PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
if
(oldstash) {
struct
mro_meta * meta;
HE *
const
entry
= (HE *)
hv_common(
seen_stashes, NULL, (
const
char
*)&oldstash,
sizeof
(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if
(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
oldstash = NULL;
goto
check_stash;
}
HeVAL(entry)
= HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
meta = HvMROMETA(oldstash);
(
void
)
hv_store(
stashes, (
const
char
*)&oldstash,
sizeof
(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
if
(HvENAME_get(oldstash)) {
const
HEK *
const
enamehek = HvENAME_HEK(oldstash);
if
(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else
{
items = 1;
svp = &namesv;
}
while
(items--) {
const
U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const
char
*name = SvPVx_const(*svp, len);
if
(PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_
"mro_gather_and_rename clearing PL_stashcache for '%"
SVf
"'\n"
,
SVfARG(*svp)));
(
void
)hv_delete_ent(PL_stashcache, *svp, G_DISCARD, 0);
}
hv_ename_delete(oldstash, name, len, name_utf8);
if
(!fetched_isarev) {
if
(HvENAME_HEK(oldstash) != enamehek) {
if
(meta->isa && HvTOTALKEYS(meta->isa))
mro_clean_isarev(meta->isa, name, len, 0, 0,
name_utf8 ? HVhek_UTF8 : 0);
isarev = (HV *)hv_delete_ent(PL_isarev, *svp, 0, 0);
fetched_isarev=TRUE;
}
}
++svp;
}
}
}
check_stash:
if
(stash) {
if
(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else
{
items = 1;
svp = &namesv;
}
while
(items--) {
const
U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const
char
*name = SvPVx_const(*svp++, len);
hv_ename_add(stash, name, len, name_utf8);
}
entry
= (HE *)
hv_common(
seen_stashes, NULL, (
const
char
*)&stash,
sizeof
(HV *), 0,
HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
);
if
(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
stash = NULL;
else
{
HeVAL(entry)
= HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
if
(!stash_had_name)
{
struct
mro_meta *
const
meta = HvMROMETA(stash);
(
void
)
hv_store(
stashes, (
const
char
*)&stash,
sizeof
(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
}
}
if
(!stash && !oldstash)
return
;
if
(!fetched_isarev) {
assert
(!oldstash || HvENAME(oldstash));
if
(oldstash) {
const
HEK *
const
hvename = HvENAME_HEK(oldstash);
fetched_isarev = TRUE;
svp = hv_fetchhek(PL_isarev, hvename, 0);
if
(svp) isarev = MUTABLE_HV(*svp);
}
else
if
(SvTYPE(namesv) == SVt_PVAV) {
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
}
else
{
items = 1;
svp = &namesv;
}
}
if
(
isarev || !fetched_isarev
) {
while
(fetched_isarev || items--) {
HE *iter;
if
(!fetched_isarev) {
HE *
const
he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
if
(!he || !(isarev = MUTABLE_HV(HeVAL(he))))
continue
;
}
hv_iterinit(isarev);
while
((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct
mro_meta * meta;
if
(!revstash)
continue
;
meta = HvMROMETA(revstash);
(
void
)
hv_store(
stashes, (
const
char
*)&revstash,
sizeof
(HV *),
meta->isa
? SvREFCNT_inc_simple_NN((SV *)meta->isa)
: &PL_sv_yes,
0
);
CLEAR_LINEAR(meta);
}
if
(fetched_isarev)
break
;
}
}
if
(oldstash && HvTOTALKEYS(oldstash)) {
xhv = (XPVHV*)SvANY(oldstash);
seen = (HV *) newSV_type_mortal(SVt_PVHV);
while
(++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(oldstash))[riter];
for
(; entry; entry = HeNEXT(entry)) {
const
char
* key;
I32 len;
if
(!isGV(HeVAL(entry)))
continue
;
key = hv_iterkey(entry, &len);
if
((len > 1 && key[len-2] ==
':'
&& key[len-1] ==
':'
)
|| (len == 1 && key[0] ==
':'
)) {
HV *
const
oldsubstash = GvHV(HeVAL(entry));
SV **stashentry;
HV *substash = NULL;
if
(oldsubstash == oldstash)
continue
;
stashentry = stash ? hv_fetchhek(stash, HeKEY_hek(entry), 0) : NULL;
if
(
(
stashentry && *stashentry && isGV(*stashentry)
&& (substash = GvHV(*stashentry))
)
|| (oldsubstash && HvHasENAME(oldsubstash))
)
{
SV *subname;
if
(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = newSV_type_mortal(SVt_PVAV);
while
(items--) {
aname = newSVsv(*svp++);
if
(len == 1)
sv_catpvs(aname,
":"
);
else
{
sv_catpvs(aname,
"::"
);
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push_simple((AV *)subname, aname);
}
}
else
{
subname = sv_2mortal(newSVsv(namesv));
if
(len == 1) sv_catpvs(subname,
":"
);
else
{
sv_catpvs(subname,
"::"
);
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, oldsubstash, subname
);
}
(
void
)hv_storehek(seen, HeKEY_hek(entry), &PL_sv_yes);
}
}
}
}
if
(stash && HvTOTALKEYS(stash)) {
xhv = (XPVHV*)SvANY(stash);
riter = -1;
while
(++riter <= (I32)xhv->xhv_max) {
entry = (HvARRAY(stash))[riter];
for
(; entry; entry = HeNEXT(entry)) {
const
char
* key;
I32 len;
if
(!isGV(HeVAL(entry)))
continue
;
key = hv_iterkey(entry, &len);
if
((len > 1 && key[len-2] ==
':'
&& key[len-1] ==
':'
)
|| (len == 1 && key[0] ==
':'
)) {
HV *substash;
if
(seen && hv_existshek(seen, HeKEY_hek(entry)))
continue
;
substash = GvHV(HeVAL(entry));
if
(substash) {
SV *subname;
if
(substash == stash)
continue
;
if
(SvTYPE(namesv) == SVt_PVAV) {
SV *aname;
items = AvFILLp((AV *)namesv) + 1;
svp = AvARRAY((AV *)namesv);
subname = newSV_type_mortal(SVt_PVAV);
while
(items--) {
aname = newSVsv(*svp++);
if
(len == 1)
sv_catpvs(aname,
":"
);
else
{
sv_catpvs(aname,
"::"
);
sv_catpvn_flags(
aname, key, len-2,
HeUTF8(entry)
? SV_CATUTF8 : SV_CATBYTES
);
}
av_push_simple((AV *)subname, aname);
}
}
else
{
subname = sv_2mortal(newSVsv(namesv));
if
(len == 1) sv_catpvs(subname,
":"
);
else
{
sv_catpvs(subname,
"::"
);
sv_catpvn_flags(
subname, key, len-2,
HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
);
}
}
mro_gather_and_rename(
stashes, seen_stashes,
substash, NULL, subname
);
}
}
}
}
}
}
void
Perl_mro_method_changed_in(pTHX_ HV *stash)
{
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
const
char
*
const
stashname = HvENAME_get(stash);
if
(!stashname)
Perl_croak(aTHX_
"Can't call mro_method_changed_in() on anonymous symbol table"
);
const
STRLEN stashname_len = HvENAMELEN_get(stash);
SV **
const
svp = hv_fetchhek(PL_isarev, HvENAME_HEK_NN(stash), 0);
HV *
const
isarev = svp ? MUTABLE_HV(*svp) : NULL;
HvMROMETA(stash)->pkg_gen++;
HvMROMETA(stash)->destroy_gen = 0;
if
((memEQs(stashname, stashname_len,
"UNIVERSAL"
))
|| (isarev && hv_existss(isarev,
"UNIVERSAL"
))) {
PL_sub_generation++;
return
;
}
if
(isarev) {
HE* iter;
hv_iterinit(isarev);
while
((iter = hv_iternext(isarev))) {
HV*
const
revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct
mro_meta* mrometa;
if
(!revstash)
continue
;
mrometa = HvMROMETA(revstash);
mrometa->cache_gen++;
if
(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
mrometa->destroy_gen = 0;
}
}
HvAMAGIC_on(stash);
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
}
void
Perl_mro_set_mro(pTHX_
struct
mro_meta *
const
meta, SV *
const
name)
{
const
struct
mro_alg *
const
which = Perl_mro_get_from_name(aTHX_ name);
PERL_ARGS_ASSERT_MRO_SET_MRO;
if
(!which)
Perl_croak(aTHX_
"Invalid mro name: '%"
SVf
"'"
, name);
if
(meta->mro_which != which) {
if
(meta->mro_linear_current && !meta->mro_linear_all) {
Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
MUTABLE_SV(meta->mro_linear_current));
}
meta->mro_which = which;
meta->mro_linear_current = NULL;
meta->cache_gen++;
if
(meta->mro_nextmethod)
hv_clear(meta->mro_nextmethod);
}
}
#include "XSUB.h"
XS(XS_mro_method_changed_in);
void
Perl_boot_core_mro(pTHX)
{
static
const
char
file[] = __FILE__;
Perl_mro_register(aTHX_ &dfs_alg);
newXSproto(
"mro::method_changed_in"
, XS_mro_method_changed_in, file,
"$"
);
}
XS(XS_mro_method_changed_in)
{
dXSARGS;
SV* classname;
HV* class_stash;
if
(items != 1)
croak_xs_usage(cv,
"classname"
);
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
if
(!class_stash) Perl_croak(aTHX_
"No such class: '%"
SVf
"'!"
, SVfARG(classname));
mro_method_changed_in(class_stash);
XSRETURN_EMPTY;
}