/* mro.c
*
* Copyright (c) 2007 Brandon L Black
- * Copyright (c) 2007, 2008 Larry Wall and others
+ * Copyright (c) 2007, 2008, 2009, 2010, 2011 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.
/*
=head1 MRO Functions
-
These functions are related to the method resolution order of perl classes
=cut
return INT2PTR(const struct mro_alg *, SvUVX(*data));
}
+/*
+=for apidoc mro_register
+Registers a custom mro plugin. See L<perlmroapi> for details.
+
+=cut
+*/
+
void
Perl_mro_register(pTHX_ const struct mro_alg *mro) {
SV *wrapper = newSVuv(PTR2UV(mro));
if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
mro->name, mro->length, mro->kflags,
HV_FETCH_ISSTORE, wrapper, mro->hash)) {
- SvREFCNT_dec(wrapper);
+ 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* 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);
newmeta->isa
= MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
+ newmeta->super = NULL;
+
return newmeta;
}
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
- Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
- HEK_KEY(stashhek));
+ Perl_croak(aTHX_
+ "Recursive inheritance detected in package '%"HEKf"'",
+ HEKfARG(stashhek));
meta = HvMROMETA(stash);
/* foreach(@ISA) */
while (items--) {
- SV* const sv = *svp++;
+ 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,
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);
-
+ sv_sethek(val, key);
av_push(retval, val);
}
}
Perl_croak(aTHX_ "panic: invalid MRO!");
isa = meta->mro_which->resolve(aTHX_ stash, 0);
+ if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
+ SV * const namesv =
+ (HvENAME(stash)||HvNAME(stash))
+ ? newSVhek(HvENAME_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 *)sv_2mortal((SV *)newAV());
+ 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();
/* Linearisation didn't build it for us, so do it here. */
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
- dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
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);
- const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
- svp = hv_fetch(PL_isarev, stashname,
- stashname_utf8 ? -stashname_len : stashname_len, 0);
+ svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
+ /* Changes to @ISA might turn overloading on */
+ HvAMAGIC_on(stash);
+ /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
+ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
+
+ /* DESTROY can be cached in SvSTASH. */
+ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
and upating PL_isarev. */
/* We have to iterate through isarev twice to avoid a chicken and
* egg problem: if A inherits from B and both are in isarev, A might
- * be processed before B and use B’s previous linearisation.
+ * be processed before B and use B's previous linearisation.
*/
/* First iteration: Wipe everything, but stash away the isa hashes
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
+ if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
(void)
hv_store(
it doesn't exist. */
(void)
- hv_store(
- mroisarev, HEK_KEY(namehek),
- HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
- &PL_sv_yes, 0
- );
+ hv_storehek(mroisarev, namehek, &PL_sv_yes);
}
- if((SV *)isa != &PL_sv_undef)
+ if ((SV *)isa != &PL_sv_undef) {
+ assert(namehek);
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
- HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
+ HvMROMETA(revstash)->isa, HEK_HASH(namehek),
+ HEK_UTF8(namehek)
);
+ }
}
}
}
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
- (void)hv_store(mroisarev, stashname,
- stashname_utf8 ? -stashname_len : stashname_len, &PL_sv_yes, 0);
+ (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
}
- /* Delete our name from our former parents’ isarevs. */
+ /* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa))
mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
- (stashname_utf8 ? SVf_UTF8 : 0) );
+ HEK_HASH(stashhek), HEK_UTF8(stashhek));
}
/* Deletes name from all the isarev entries listed in isa */
STATIC void
S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
- const STRLEN len, HV * const exceptions, U32 flags)
+ const STRLEN len, HV * const exceptions, U32 hash,
+ U32 flags)
{
HE* iter;
PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
- /* Delete our name from our former parents’ isarevs. */
+ /* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
SV **svp;
while((iter = hv_iternext(isa))) {
svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
if(svp) {
HV * const isarev = (HV *)*svp;
- (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -len : len, G_DISCARD);
+ (void)hv_common(isarev, NULL, name, len, flags,
+ G_DISCARD|HV_DELETE, NULL, hash);
if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
(void)hv_delete(PL_isarev, key,
HeKUTF8(iter) ? -klen : klen, G_DISCARD);
=for apidoc mro_package_moved
Call this function to signal to a stash that it has been assigned to
-another spot in the stash hierarchy. C<stash> is the stash that has been
-assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
+another spot in the stash hierarchy. C<stash> is the stash that has been
+assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
that is actually being assigned to.
This can also be called with a null first argument to
appropriate.
If the C<gv> is present and is not in the symbol table, then this function
-simply returns. This checked will be skipped if C<flags & 1>.
+simply returns. This checked will be skipped if C<flags & 1>.
=cut
*/
SV **svp;
if(
!GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
- !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
- GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
+ !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
*svp != (SV *)gv
) return;
}
else sv_catpvs(namesv, "::");
}
if (GvNAMELEN(gv) != 1) {
- sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2);
+ sv_catpvn_flags(
+ namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
- if ( GvNAMEUTF8(gv) )
- SvUTF8_on(namesv);
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
else {
else sv_catpvs(aname, "::");
}
if (GvNAMELEN(gv) != 1) {
- sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2);
+ sv_catpvn_flags(
+ aname, GvNAME(gv), GvNAMELEN(gv) - 2,
/* skip trailing :: */
- if ( GvNAMEUTF8(gv) )
- SvUTF8_on(aname);
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
av_push((AV *)namesv, aname);
}
}
}
-void
+STATIC void
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
HV *stash, HV *oldstash, SV *namesv)
{
- register XPVHV* xhv;
- register HE *entry;
+ XPVHV* xhv;
+ HE *entry;
I32 riter = -1;
I32 items = 0;
const bool stash_had_name = stash && HvENAME(stash);
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
- const char *name = SvPVx_const(*svp++, len);
- if(PL_stashcache)
- (void)hv_delete(PL_stashcache, name, name_utf8 ? -len : len, G_DISCARD);
+ 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(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
+ }
+ ++svp;
hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
* are not going to call mro_isa_changed_in with this
* name (and not at all if it has become anonymous) so
* we need to delete old isarev entries here, both
- * those in the superclasses and this class’s own list
+ * those in the superclasses and this class's own list
* of subclasses. We simply delete the latter from
* PL_isarev, since we still need it. hv_delete morti-
* fies it for us, so sv_2mortal is not necessary. */
if(HvENAME_HEK(oldstash) != enamehek) {
if(meta->isa && HvARRAY(meta->isa))
- mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
+ mro_clean_isarev(meta->isa, name, len, 0, 0,
+ name_utf8 ? HVhek_UTF8 : 0);
isarev = (HV *)hv_delete(PL_isarev, name,
- name_utf8 ? -len : len, 0);
+ name_utf8 ? -(I32)len : (I32)len, 0);
fetched_isarev=TRUE;
}
}
/* Add it to the big list if it needs
* mro_isa_changed_in called on it. That happens if it was
* detached from the symbol table (so it had no HvENAME) before
- * being assigned to the spot named by the ‘name’ variable, because
+ * being assigned to the spot named by the 'name' variable, because
* its cached isa linearisation is now stale (the effective name
* having changed), and subclasses will then use that cache when
* mro_package_moved calls mro_isa_changed_in. (See
assert(!oldstash || HvENAME(oldstash));
if (oldstash) {
/* Extra variable to avoid a compiler warning */
- char * const hvename = HvENAME(oldstash);
+ const HEK * const hvename = HvENAME_HEK(oldstash);
fetched_isarev = TRUE;
- svp = hv_fetch(PL_isarev, hvename,
- HvENAMEUTF8(oldstash)
- ? -HvENAMELEN_get(oldstash)
- : HvENAMELEN_get(oldstash), 0);
+ svp = hv_fetchhek(PL_isarev, hvename, 0);
if (svp) isarev = MUTABLE_HV(*svp);
}
else if(SvTYPE(namesv) == SVt_PVAV) {
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
- SV* keysv;
const char* key;
- STRLEN len;
+ I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
- keysv = hv_iterkeysv(entry);
- key = SvPV_const(keysv, len);
+ 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 ** const stashentry
- = stash ? hv_fetch(stash, key, SvUTF8(keysv) ? -len : len, 0) : NULL;
+ = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
HV *substash = NULL;
/* Avoid main::main::main::... */
if(
(
- stashentry && *stashentry
+ stashentry && *stashentry && isGV(*stashentry)
&& (substash = GvHV(*stashentry))
)
|| (oldsubstash && HvENAME_get(oldsubstash))
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
- sv_catpvn(aname, key, len-2);
- if ( SvUTF8(keysv) )
- SvUTF8_on(aname);
+ sv_catpvn_flags(
+ aname, key, len-2,
+ HeUTF8(entry)
+ ? SV_CATUTF8 : SV_CATBYTES
+ );
}
av_push((AV *)subname, aname);
}
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
- sv_catpvn(subname, key, len-2);
- if ( SvUTF8(keysv) )
- SvUTF8_on(subname);
+ sv_catpvn_flags(
+ subname, key, len-2,
+ HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
mro_gather_and_rename(
);
}
- (void)hv_store(seen, key, SvUTF8(keysv) ? -len : len, &PL_sv_yes, 0);
+ (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
}
}
}
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
- SV* keysv;
const char* key;
- STRLEN len;
+ I32 len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
- keysv = hv_iterkeysv(entry);
- key = SvPV_const(keysv, len);
+ key = hv_iterkey(entry, &len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV *substash;
/* If this entry was seen when we iterated through the
oldstash, skip it. */
- if(seen && hv_exists(seen, key, SvUTF8(keysv) ? -len : len)) continue;
+ if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
/* We get here only if this stash has no corresponding
entry in the stash being replaced. */
sv_catpvs(aname, ":");
else {
sv_catpvs(aname, "::");
- sv_catpvn(aname, key, len-2);
- if ( SvUTF8(keysv) )
- SvUTF8_on(aname);
+ sv_catpvn_flags(
+ aname, key, len-2,
+ HeUTF8(entry)
+ ? SV_CATUTF8 : SV_CATBYTES
+ );
}
av_push((AV *)subname, aname);
}
if (len == 1) sv_catpvs(subname, ":");
else {
sv_catpvs(subname, "::");
- sv_catpvn(subname, key, len-2);
- if ( SvUTF8(keysv) )
- SvUTF8_on(subname);
+ sv_catpvn_flags(
+ subname, key, len-2,
+ HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
mro_gather_and_rename(
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
-perl source outside of C<mro.c> should be
+perl source outside of F<mro.c> should be
replaced by calls to this.
Perl automatically handles most of the common
{
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
- const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
- SV ** const svp = hv_fetch(PL_isarev, stashname,
- stashname_utf8 ? -stashname_len : stashname_len, 0);
+ SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
/* Inc the package generation, since a local method changed */
HvMROMETA(stash)->pkg_gen++;
+ /* DESTROY can be cached in SvSTASH. */
+ if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
+
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
+ if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
}
}
+
+ /* The method change may be due to *{$package . "::()"} = \&nil; in
+ overload.pm. */
+ HvAMAGIC_on(stash);
+ /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
+ HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
}
void
void
Perl_boot_core_mro(pTHX)
{
- dVAR;
static const char file[] = __FILE__;
Perl_mro_register(aTHX_ &dfs_alg);
XS(XS_mro_method_changed_in)
{
- dVAR;
dXSARGS;
SV* classname;
HV* class_stash;
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
* End:
*
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff