X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=f757f4c339c89e8c95922b4eedc61616e72e8894;hb=5c144d81801caa5e8317f6a38b40eb08257c47ea;hp=0f3fa2467d5bd04335905aaa248352ae902c25a4;hpb=f54cb97a39f1a5849851e77a33524dfca2644cf5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 0f3fa24..f757f4c 100644 --- a/gv.c +++ b/gv.c @@ -111,7 +111,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) dVAR; register GP *gp; const bool doproto = SvTYPE(gv) > SVt_NULL; - const char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL; sv_upgrade((SV*)gv, SVt_PVGV); if (SvLEN(gv)) { @@ -120,7 +120,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) SvLEN_set(gv, 0); SvPOK_off(gv); } else - Safefree(SvPVX(gv)); + Safefree(SvPVX_const(gv)); } Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); @@ -201,6 +201,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) GV* gv; GV** gvp; CV* cv; + const char *hvname; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { @@ -209,15 +210,16 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) return 0; } - if (!HvNAME(stash)) + hvname = HvNAME_get(stash); + if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", - name, HvNAME(stash)); + name, hvname); - DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) @@ -244,19 +246,18 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* create and re-create @.*::SUPER::ISA on demand */ if (!av || !SvMAGIC(av)) { - const char* packname = HvNAME(stash); - STRLEN packlen = strlen(packname); + STRLEN packlen = HvNAMELEN_get(stash); - if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { HV* basestash; packlen -= 7; - basestash = gv_stashpvn(packname, packlen, TRUE); + basestash = gv_stashpvn(hvname, packlen, TRUE); gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); if (!gvp || !(gv = *gvp)) - Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); + Perl_croak(aTHX_ "Cannot create %s::ISA", hvname); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); @@ -275,7 +276,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if (!basestash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); + sv, hvname); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -433,9 +434,9 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) 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); + stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME(stash), name) ); + origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ @@ -491,16 +492,18 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) GV* vargv; SV* varsv; const char *packname = ""; + STRLEN packname_len; if (len == S_autolen && strnEQ(name, S_autoload, S_autolen)) return Nullgv; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_nolen((SV*)stash); + packname = SvPV((SV*)stash, packname_len); stash = Nullhv; } else { - packname = HvNAME(stash); + packname = HvNAME_get(stash); + packname_len = HvNAMELEN_get(stash); } } if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) @@ -545,7 +548,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); LEAVE; varsv = GvSV(vargv); - sv_setpv(varsv, packname); + sv_setpvn(varsv, packname, packname_len); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); @@ -561,7 +564,7 @@ S_require_errno(pTHX_ GV *gv) dVAR; HV* stash = gv_stashpvn("Errno",5,FALSE); - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { dSP; PUTBACK; ENTER; @@ -629,8 +632,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savepv(name); + if (!HvNAME_get(stash)) + Perl_hv_name_set(aTHX_ stash, name, namelen, 0); return stash; } @@ -647,7 +650,7 @@ HV* Perl_gv_stashsv(pTHX_ SV *sv, I32 create) { STRLEN len; - const char *ptr = SvPV(sv,len); + const char *ptr = SvPV_const(sv,len); return gv_stashpvn(ptr, len, create); } @@ -660,7 +663,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { GV * Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { STRLEN len; - const char *nambeg = SvPV(name, len); + const char *nambeg = SvPV_const(name, len); return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } @@ -718,8 +721,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); - if (!HvNAME(stash)) - HvNAME(stash) = savepvn(nambeg, namend - nambeg); + if (!HvNAME_get(stash)) + Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0); } if (*namend == ':') @@ -849,7 +852,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; @@ -864,7 +867,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } else #endif { - const char *name2 = name + 1; + const char * const name2 = name + 1; switch (*name) { case 'A': if (strEQ(name2, "RGV")) { @@ -932,6 +935,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; + case '\003': /* $^CHILD_ERROR_NATIVE */ + if (strEQ(name2, "HILD_ERROR_NATIVE")) + goto magicalize; + break; case '\005': /* $^ENCODING */ if (strEQ(name2, "NCODING")) goto magicalize; @@ -945,9 +952,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, goto ro_magicalize; break; case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ - if (strEQ(name2, "NICODE")) + if (strEQ(name2, "NICODE")) goto ro_magicalize; - if (strEQ(name2, "TF8LOCALE")) + if (strEQ(name2, "TF8LOCALE")) goto ro_magicalize; break; case '\027': /* $^WARNING_BITS */ @@ -998,7 +1005,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '?': #ifdef COMPLEX_STATUS - (void)SvUPGRADE(GvSV(gv), SVt_PVLV); + SvUPGRADE(GvSV(gv), SVt_PVLV); #endif goto magicalize; @@ -1087,11 +1094,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\014': /* $^L */ - sv_setpv(GvSV(gv),"\f"); + sv_setpvn(GvSV(gv),"\f",1); PL_formfeed = GvSV(gv); break; case ';': - sv_setpv(GvSV(gv),"\034"); + sv_setpvn(GvSV(gv),"\034",1); break; case ']': { @@ -1120,19 +1127,24 @@ void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { const char *name; + STRLEN namelen; const HV * const hv = GvSTASH(gv); if (!hv) { SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); - - name = HvNAME(hv); - if (!name) + + name = HvNAME_get(hv); + if (name) { + namelen = HvNAMELEN_get(hv); + } else { name = "__ANON__"; - + namelen = 8; + } + if (keepmain || strNE(name, "main")) { - sv_catpv(sv,name); + sv_catpvn(sv,name,namelen); sv_catpvn(sv,"::", 2); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); @@ -1182,8 +1194,7 @@ Perl_newIO(pTHX) sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a - package name */ + /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ @@ -1238,7 +1249,7 @@ Perl_gv_check(pTHX_ HV *stash) #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", - HvNAME(stash), GvNAME(gv)); + HvNAME_get(stash), GvNAME(gv)); } } } @@ -1300,12 +1311,14 @@ Perl_gp_free(pTHX_ GV *gv) if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); if (gp->gp_av) SvREFCNT_dec(gp->gp_av); - if (gp->gp_hv) { - if (PL_stashcache && HvNAME(gp->gp_hv)) - hv_delete(PL_stashcache, - HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), - G_DISCARD); - SvREFCNT_dec(gp->gp_hv); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { + const char *hvname = HvNAME_get(gp->gp_hv); + if (PL_stashcache && hvname) + hv_delete(PL_stashcache, hvname, HvNAMELEN_get(gp->gp_hv), + G_DISCARD); + SvREFCNT_dec(gp->gp_hv); } if (gp->gp_io) SvREFCNT_dec(gp->gp_io); if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); @@ -1350,7 +1363,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) return (bool)AMT_OVERLOADED(amtp); sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); - DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; @@ -1385,8 +1398,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); const STRLEN l = strlen(cooky); - DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", - cp, HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", + cp, HvNAME_get(stash)) ); /* don't fill the cache while looking up! Creation of inheritance stubs in intermediate packages may conflict with the logic of runtime method substitution. @@ -1400,33 +1413,34 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { + const char *hvname; if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + && strEQ(hvname = HvNAME_get(GvSTASH(CvGV(cv))), "overload")) { /* This is a hack to support autoloading..., while knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ GV *ngv = Nullgv; - - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\ - "' for overloaded `%s' in package `%.256s'\n", - GvSV(gv), cp, HvNAME(stash)) ); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + GvSV(gv), cp, hvname) ); if (!SvPOK(GvSV(gv)) - || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), + || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)), FALSE))) { - /* Can be an import stub (created by `can'). */ + /* Can be an import stub (created by "can"). */ SV *gvsv = GvSV(gv); - const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???"; - Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\ - "in package `%.256s'", + const char * const name = SvPOK(gvsv) ? SvPVX_const(gvsv) : "???"; + Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\ + "in package \"%.256s\"", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), - name, cp, HvNAME(stash)); + name, cp, hvname); } cv = GvCV(gv = ngv); } - DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", - cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; if (i < DESTROY_amg) @@ -1461,7 +1475,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) MAGIC *mg; AMT *amtp; - if (!stash || !HvNAME(stash)) + if (!stash || !HvNAME_get(stash)) return Nullcv; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { @@ -1487,7 +1501,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) } return ret; } - + return Nullcv; } @@ -1500,8 +1514,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; AMT *amtp=NULL, *oamtp=NULL; - int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0; - int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; + int off = 0, off1, lr = 0, notfound = 0; + int postpr = 0, force_cpy = 0; + int assign = AMGf_assign & flags; + const int assignshift = assign ? 1 : 0; #ifdef DEBUGGING int fl=0; #endif @@ -1518,7 +1534,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ( #ifdef DEBUGGING fl = 1, -#endif +#endif cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { @@ -1685,14 +1701,14 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation `%s': no method found,%sargument %s%s%s%s", + "Operation \"%s\": no method found,%sargument %s%s%s%s", AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? - HvNAME(SvSTASH(SvRV(left))): + HvNAME_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": @@ -1700,10 +1716,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? - HvNAME(SvSTASH(SvRV(right))): + HvNAME_get(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { - DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { Perl_croak(aTHX_ "%"SVf, msg); } @@ -1715,17 +1731,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", AMG_id2name(off), method+assignshift==off? "" : - " (initially `", + " (initially \"", method+assignshift==off? "" : AMG_id2name(method+assignshift), - method+assignshift==off? "" : "')", + method+assignshift==off? "" : "\")", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME(stash) : "null", + stash ? HvNAME_get(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif @@ -1875,7 +1891,7 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) { (void)flags; if (len > 1) { - const char *name1 = name + 1; + const char * const name1 = name + 1; switch (*name) { case 'I': if (len == 3 && name1[1] == 'S' && name[2] == 'A') @@ -1903,7 +1919,7 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case '\025': /* ${^UNICODE} */ if (strEQ(name1, "NICODE")) goto yes; - if (strEQ(name1, "TF8LOCALE")) + if (strEQ(name1, "TF8LOCALE")) goto yes; break; case '\027': /* ${^WARNING_BITS} */ @@ -1989,3 +2005,13 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) } return FALSE; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */