/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */ static HV* S_guess_stash(pTHX_ SV* sv) { if (SvOBJECT(sv)) { return SvSTASH(sv); } else { HV *stash = NULL; switch (SvTYPE(sv)) { case SVt_PVCV: if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv))) return GvSTASH(CvGV(sv)); else if (/* !CvANON(sv) && */ CvSTASH(sv)) return CvSTASH(sv); break; case SVt_PVGV: if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv))) return GvESTASH(MUTABLE_GV(sv)); break; default: break; } return stash; } }
int mop_get_code_info (SV *coderef, char **pkg, char **name) { if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { return 0; } coderef = SvRV(coderef); /* sub is still being compiled */ if (!CvGV(coderef)) { return 0; } /* I think this only gets triggered with a mangled coderef, but if we hit it without the guard, we segfault. The slightly odd return value strikes me as an improvement (mst) */ if ( isGV_with_GP(CvGV(coderef)) ) { GV *gv = CvGV(coderef); *pkg = HvNAME( GvSTASH(gv) ? GvSTASH(gv) : CvSTASH(coderef) ); *name = GvNAME( CvGV(coderef) ); } else { *pkg = "__UNKNOWN__"; *name = "__ANON__"; } return 1; }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!CvROOT(cv)) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN(WARN_DEPRECATED) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; #ifdef USE_THREADS sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); #ifdef USE_THREADS sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv) { char *name = NULL; GV *gv; if (SvROK(sv)) { sv = SvRV(sv); } switch (SvTYPE(sv)) { case SVt_PV: name = SvPVX(sv); return modperl_handler_new(p, apr_pstrdup(p, name)); break; case SVt_PVCV: if (CvANON((CV*)sv)) { return modperl_handler_new_anon(aTHX_ p, (CV*)sv); } if (!(gv = CvGV((CV*)sv))) { Perl_croak(aTHX_ "can't resolve the code reference"); } name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL); return modperl_handler_new(p, name); default: break; }; return NULL; }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else stash = gv_stashpvn(origname, nsplit - origname, TRUE); } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
SV *PerlIONginxInput_newhandle(pTHX_ ngx_http_request_t *r) { ngx_log_t *log = r->connection->log; GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Input")); if (!gv) return &PL_sv_undef; (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); /* Body in memory */ if (r->request_body == NULL || r->request_body->temp_file == NULL) { ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "Open filehandle with 'ngx_input' layer to read from buffers"); PerlIO *f = PerlIO_allocate(aTHX); if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_input), "<", NULL)) ) { ngx_log_error(NGX_LOG_ERR, log, 0, "Error pushing layer to FH" ); return &PL_sv_undef; } if (!do_open(gv, "+<&", 3, FALSE, O_RDONLY, 0, f)) { ngx_log_error(NGX_LOG_ERR, log, 0, "Error opening GV" ); // FIXME PerlIO_close return &PL_sv_undef; } PerlIONginxInput *st = PerlIOSelf(f, PerlIONginxInput); st->r = r; } else { /* Body in temp file */ ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "Open PSGI request body temp file '%s'", r->request_body->temp_file->file.name.data ); bool result = do_open(gv,(char*)r->request_body->temp_file->file.name.data, r->request_body->temp_file->file.name.len,FALSE,O_RDONLY,0,NULL); if (!result) { ngx_log_error(NGX_LOG_ERR, log, 0, "Error opening file" ); // FIXME PerlIO_close return NULL; } } return (SV*)newRV_noinc((SV *)gv); }
void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { register GP *gp; bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; sv_upgrade((SV*)gv, SVt_PVGV); if (SvLEN(gv)) { if (proto) { SvPVX(gv) = NULL; SvLEN(gv) = 0; SvPOK_off(gv); } else Safefree(SvPVX(gv)); } Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); GvLINE(gv) = CopLINE(PL_curcop); GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; /* XXX unsafe for threads if eval_owner isn't held */ start_subparse(0,0); /* Create CV in compcv. */ GvCV(gv) = PL_compcv; LEAVE; PL_sub_generation++; CvGV(GvCV(gv)) = gv; CvFILE(GvCV(gv)) = CopFILE(PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; #ifdef USE_THREADS CvOWNER(GvCV(gv)) = 0; if (!CvMUTEXP(GvCV(gv))) { New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(GvCV(gv))); } #endif /* USE_THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); } } }
SV* THX_MopMcV_get_method(pTHX_ SV* metaclass, SV* name) { HV* stash = (HV*) SvRV(metaclass); HE* method_gv_he = hv_fetch_ent(stash, name, 0, 0); if (method_gv_he != NULL) { GV* method_gv = (GV*) HeVAL(method_gv_he); CV* method = GvCV(method_gv); if (method != NULL && GvSTASH(CvGV(method)) == stash) { return newRV_inc((SV*) method); } } return NULL; }
bool THX_MopMcV_has_method(pTHX_ SV* metaclass, SV* name) { HV* stash = (HV*) SvRV(metaclass); HE* method_gv_he = hv_fetch_ent(stash, name, 0, 0); if (method_gv_he != NULL) { GV* method_gv = (GV*) HeVAL(method_gv_he); CV* method = GvCV(method_gv); if (method != NULL && GvSTASH(CvGV(method)) == stash) { return TRUE; } } return FALSE; }
STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } }
SV *PerlIONginxError_newhandle(pTHX_ ngx_http_request_t *r) { GV *gv = (GV*)SvREFCNT_inc(newGVgen("Nginx::PSGI::Error")); if (!gv) return &PL_sv_undef; (void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); PerlIO *f = PerlIO_allocate(aTHX); if (!(f = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_nginx_error), ">", NULL)) ) { return &PL_sv_undef; } if (!do_open(gv, "+>&", 3, FALSE, O_WRONLY, 0, f)) { return &PL_sv_undef; } PerlIONginxError *st = PerlIOSelf(f, PerlIONginxError); st->log = r->connection->log; return newRV_noinc((SV*)gv); }
static void modperl_package_clear_stash(pTHX_ const char *package) { HV *stash; if ((stash = gv_stashpv(package, FALSE))) { HE *he; I32 len; char *key; hv_iterinit(stash); while ((he = hv_iternext(stash))) { key = hv_iterkey(he, &len); if (MP_SAFE_STASH(key, len)) { SV *val = hv_iterval(stash, he); /* The safe thing to do is to skip over stash entries * that don't come from the package we are trying to * unload */ if (GvSTASH(val) == stash) { (void)hv_delete(stash, key, len, G_DISCARD); } } } } }
GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { char autoload[] = "AUTOLOAD"; STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; char *packname = ""; if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { packname = SvPV_nolen((SV*)stash); stash = Nullhv; } else { packname = HvNAME(stash); } } if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); if (CvXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', * pass along the same data via some unused fields in the CV */ CvSTASH(cv) = stash; SvPVX(cv) = (char *)name; /* cast to lose constness warning */ SvCUR(cv) = len; return gv; } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't * use that, but for lack of anything better we will use the sub's * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); sv_setpv(varsv, packname); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); return gv; }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; HV* ostash = stash; if (stash && SvTYPE(stash) < SVt_PVHV) stash = Nullhv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, FALSE); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, FALSE)) stash = gv_stashpvn(origname, nsplit - origname, TRUE); } ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
void c_test (int max){ int i; for (f=1) } #line 23 "ko_6_1_0_perllint_01cc.c" #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(var) if (0) var = var #endif #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params) /* prototype to pass -Wmissing-prototypes */ STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params); STATIC void S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); else Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE #ifdef PERL_IMPLICIT_CONTEXT #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b) #else #define croak_xs_usage S_croak_xs_usage #endif #endif /* NOTE: the prototype of newXSproto() is different in versions of perls, * so we define a portable version of newXSproto() */ #ifdef newXS_flags #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0) #else #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv) #endif /* !defined(newXS_flags) */ #line 75 "ko_6_1_0_perllint_01cc.c" XS(XS_main_c_test); /* prototype to pass -Wmissing-prototypes */ XS(XS_main_c_test) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif if (items != 1) croak_xs_usage(cv, "max"); PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; { int max = (int)SvIV(ST(0)); #line 22 "ko_6_1_0_perllint_01cc.xs" I32* temp; #line 93 "ko_6_1_0_perllint_01cc.c" #line 24 "ko_6_1_0_perllint_01cc.xs" temp = PL_markstack_ptr++; c_test(max); if (PL_markstack_ptr != temp) { /* truly void, because dXSARGS not invoked */ PL_markstack_ptr = temp; XSRETURN_EMPTY; /* return empty stack */ } /* must have used dXSARGS; list context implied */ return; /* assume stack size is correct */ #line 104 "ko_6_1_0_perllint_01cc.c" PUTBACK; return; } } #ifdef __cplusplus extern "C" #endif XS(boot_ko_6_1_0_perllint_01cc); /* prototype to pass -Wmissing-prototypes */ XS(boot_ko_6_1_0_perllint_01cc) { #ifdef dVAR dVAR; dXSARGS; #else dXSARGS; #endif #if (PERL_REVISION == 5 && PERL_VERSION < 9) char* file = __FILE__; #else const char* file = __FILE__; #endif PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XS_VERSION_BOOTCHECK ; newXS("main::c_test", XS_main_c_test, file); #if (PERL_REVISION == 5 && PERL_VERSION >= 9) if (PL_unitcheckav) call_list(PL_scopestack_ix, PL_unitcheckav); #endif XSRETURN_YES; }
/* =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); } } }