/*
=for apidoc mro_get_linear_isa_dfs
Returns the Depth-First Search linearization of @ISA
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
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;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
assert(HvAUX(stash));
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'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return retval;
}
/* not in cache, make a new one */
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);
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;
/* "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 = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
if(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
while (items--) {
SV* const sv = *svp++;
HV* const basestash = gv_stashsv(sv, 0);
SV *const *subrv_p;
I32 subrv_items;
if (!basestash) {
/* if no stash exists for this @ISA member,
simply add it to the MRO and move on */
subrv_p = &sv;
subrv_items = 1;
}
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, hence the use of
the mortal. */
const AV *const subrv
= mro_get_linear_isa_dfs(basestash, level + 1);
subrv_p = AvARRAY(subrv);
subrv_items = AvFILLp(subrv) + 1;
}
while(subrv_items--) {
SV *const subsv = *subrv_p++;
/* 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. */
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 */
SvREADONLY_on(retval);
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}
/*
=for apidoc mro_get_linear_isa_dfs
Returns the Depth-First Search linearization of C<@ISA>
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
You are responsible for C<SvREFCNT_inc()> on the
return value if you plan to store it anywhere
semi-permanently (otherwise it might be deleted
out from under you the next time the cache is
invalidated).
=cut
*/
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);
/* return cache if valid */
if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
return retval;
}
/* not in cache, make a new one */
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);
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;
/* "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. */
if(av && AvFILLp(av) >= 0) {
SV **svp = AvARRAY(av);
I32 items = AvFILLp(av) + 1;
/* foreach(@ISA) */
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) {
/* if no stash exists for this @ISA member,
simply add it to the MRO and move on */
subrv_p = &sv;
subrv_items = 1;
}
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, hence the use of
the mortal. */
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++;
/* 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;
sv_sethek(val, key);
av_push(retval, val);
}
}
} else {
/* We are the first (or only) parent. We can short cut the
complexity above, because our @ISA is simply us prepended
to our parent's @ISA, and our ->isa cache is simply our
parent's, with our name added. */
/* newSVsv() is slow. This code is only faster if we can avoid
it by ensuring that SVs in the arrays are shared hash key
scalar SVs, because we can "copy" them very efficiently.
Although to be fair, we can't *ensure* this, as a reference
to the internal array is returned by mro::get_linear_isa(),
so we'll have to be defensive just in case someone faffed
with it. */
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 {
/* They have no stash. So create ourselves an ->isa cache
as if we'd copied it from what theirs should be. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
}
}
}
} else {
/* We have no parents. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
(void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
}
(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;
/* 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 */
SvREADONLY_on(retval);
return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
MUTABLE_SV(retval)));
}