static void S_attributes__push_fetch(pTHX_ SV *sv) { dSP; switch (SvTYPE(sv)) { case SVt_PVCV: { cv_flags_t cvflags = CvFLAGS((const CV *)sv); if (cvflags & CVf_LVALUE) { XPUSHs(newSVpvs_flags("lvalue", SVs_TEMP)); } if (cvflags & CVf_METHOD) { XPUSHs(newSVpvs_flags("method", SVs_TEMP)); } if (cvflags & CVf_PURE) { XPUSHs(newSVpvs_flags("pure", SVs_TEMP)); } if (cvflags & CVf_TYPED) { HV *typestash = CvTYPE((CV*)sv); XPUSHs(newSVpvn_flags(HvNAME(typestash), HvNAMELEN(typestash), SVs_TEMP|HvNAMEUTF8(typestash))); } break; } default: break; } PUTBACK; }
/* =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 that is actually being assigned to. This can also be called with a null first argument to indicate that C<oldstash> has been deleted. This function invalidates isa caches on the old stash, on all subpackages nested inside it, and on the subclasses of all those, including non-existent packages that have corresponding entries in C<stash>. It also sets the effective names (C<HvENAME>) on all the stashes as 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>. =cut */ 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); /* Determine the name(s) of the location that stash was assigned to * or from which oldstash was removed. * * We cannot reliably use the name in oldstash, because it may have * been deleted from the location in the symbol table that its name * suggests, as in this case: * * $globref = \*foo::bar::; * Symbol::delete_package("foo"); * *$globref = \%baz::; * *$globref = *frelp::; * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0) * * So we get it from the gv. But, since the gv may no longer be in the * symbol table, we check that first. The only reliable way to tell is * to see whether its stash has an effective name and whether the gv * resides in that stash under its name. That effective name may be * different from what gv_fullname4 would use. * If flags & 1, the caller has asked us to skip the check. */ if(!(flags & 1)) { SV **svp; if( !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) || !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) || *svp != (SV *)gv ) return; } assert(SvOOK(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 (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) { namesv = GvNAMELEN(gv) == 1 ? newSVpvs_flags(":", SVs_TEMP) : newSVpvs_flags("", SVs_TEMP); } else { namesv = sv_2mortal(newSVhek(*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, /* skip trailing :: */ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES ); } } else { SV *aname; namesv = sv_2mortal((SV *)newAV()); while (name_count--) { if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) { 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, /* skip trailing :: */ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES ); } av_push((AV *)namesv, aname); } } /* Get a list of all the affected classes. */ /* We cannot simply pass them all to mro_isa_changed_in to avoid the list, as that function assumes that only one package has changed. It does not work with: @foo::ISA = qw( B B::B ); *B:: = delete $::{"A::"}; as neither B nor B::B can be updated before the other, since they will reset caches on foo, which will see either B or B::B with the wrong name. The names must be set on *all* affected stashes before we do anything else. (And linearisations must be cleared, too.) */ stashes = (HV *) sv_2mortal((SV *)newHV()); mro_gather_and_rename( stashes, (HV *) sv_2mortal((SV *)newHV()), stash, oldstash, namesv ); /* Once the caches have been wiped on all the classes, call mro_isa_changed_in on each. */ hv_iterinit(stashes); while((iter = hv_iternext(stashes))) { HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter)); if(HvENAME(stash)) { /* We have to restore the original meta->isa (that mro_gather_and_rename set aside for us) this way, in case one class in this list is a superclass of a another class that we have already encountered. In such a case, meta->isa from PL_isarev. */ struct mro_meta * const meta = HvMROMETA(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; /* We donated our reference count. */ } mro_isa_changed_in(stash); } } }