X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=62afd9163ebef97874a1ac28ddfd4c949ce84c54;hb=2f9daededa74ef1264bd2c46743008f84bff0cfc;hp=c136fc5ed45fd14d7f51bc35bc127db068751702;hpb=dc437b5767e75ec9db9c2a0bb7ea934b28a3fe8a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index c136fc5..62afd91 100644 --- a/gv.c +++ b/gv.c @@ -19,7 +19,7 @@ #include "EXTERN.h" #include "perl.h" -extern char rcsid[]; +EXT char rcsid[]; GV * gv_AVadd(gv) @@ -59,12 +59,16 @@ gv_fetchfile(name) char *name; { char tmpbuf[1200]; + STRLEN tmplen; GV *gv; - sprintf(tmpbuf,"::_<%s", name); - gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); + sprintf(tmpbuf, "_<%s", name); + tmplen = strlen(tmpbuf); + gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); + if (!isGV(gv)) + gv_init(gv, defstash, tmpbuf, tmplen, FALSE); sv_setpv(GvSV(gv), name); - if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) + if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) GvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); @@ -84,9 +88,8 @@ int multi; sv_upgrade((SV*)gv, SVt_PVGV); if (SvLEN(gv)) Safefree(SvPVX(gv)); - Newz(602,gp, 1, GP); + Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); - GvREFCNT(gv) = 1; GvSV(gv) = NEWSV(72,0); GvLINE(gv) = curcop->cop_line; GvFILEGV(gv) = curcop->cop_filegv; @@ -133,29 +136,28 @@ I32 level; if (!stash) return 0; - if (level > 100) + if ((level > 100) || (level < -100)) croak("Recursive inheritance detected"); - gvp = (GV**)hv_fetch(stash, name, len, TRUE); - DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); - topgv = *gvp; - if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); - - if (cv=GvCV(topgv)) { - if (GvCVGEN(topgv) >= sub_generation) - return topgv; /* valid cached inheritance */ - if (!GvCVGEN(topgv)) { /* not an inheritance cache */ - return topgv; - } - else { - /* stale cached entry, just junk it */ - GvCV(topgv) = cv = 0; + + gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + if (!gvp) + topgv = Nullgv; + else { + topgv = *gvp; + if (SvTYPE(topgv) != SVt_PVGV) + gv_init(topgv, stash, name, len, TRUE); + if (cv = GvCV(topgv)) { + /* If genuine method or valid cache entry, use it */ + if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) + return topgv; + /* Stale cached entry: junk it */ + SvREFCNT_dec(cv); + GvCV(topgv) = cv = Nullcv; GvCVGEN(topgv) = 0; } } - /* if cv is still set, we have to free it if we find something to cache */ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { @@ -170,30 +172,25 @@ I32 level; SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len, level + 1); - if (gv) { - if (cv) { /* junk old undef */ - assert(SvREFCNT(topgv) > 1); - SvREFCNT_dec(topgv); - SvREFCNT_dec(cv); - } - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ - return gv; - } + gv = gv_fetchmeth(basestash, name, len, + (level >= 0) ? level + 1 : level - 1); + if (gv) + goto gotcha; } } - if (!level) { + if (level == 0 || level == -1) { if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { - if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { - if (cv) { /* junk old undef */ - assert(SvREFCNT(topgv) > 1); - SvREFCNT_dec(topgv); - SvREFCNT_dec(cv); + if (gv = gv_fetchmeth(lastchance, name, len, + (level >= 0) ? level + 1 : level - 1)) { + gotcha: + /* Use topgv for cache only if it has no synonyms */ + if (topgv && GvREFCNT(topgv) == 1) { + if (cv = GvCV(topgv)) + SvREFCNT_dec(cv); + GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); + GvCVGEN(topgv) = sub_generation; } - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; } } @@ -241,9 +238,10 @@ char* name; /* Failed obvious case - look for SUPER as last element of stash's name */ char *packname = HvNAME(stash); STRLEN len = strlen(packname); - if ((len -= 7) >= 0 && strEQ(packname+len,"::SUPER")) { + if (len >= 7 && strEQ(packname+len-7,"::SUPER")) { /* Now look for @.*::SUPER::ISA */ GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); + len -= 7; if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) { /* No @ISA in package ending in ::SUPER - drop suffix and see if there is an @ISA there @@ -273,22 +271,50 @@ char* name; } if (!gv) { - CV* cv; - - if (strEQ(name,"import") || strEQ(name,"unimport")) + if (strEQ(name,"import")) gv = (GV*)&sv_yes; - else if (strNE(name, "AUTOLOAD")) { - gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0); - if (gv && (cv = GvCV(gv))) { /* One more chance... */ - SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); - sv_catpvn(tmpstr,"::", 2); - sv_catpvn(tmpstr, name, nend - name); - sv_setsv(GvSV(CvGV(cv)), tmpstr); - if (tainting) - sv_unmagic(GvSV(CvGV(cv)), 't'); - } - } + else + gv = gv_autoload(stash, name, nend - name); } + + return gv; +} + +GV* +gv_autoload(stash, name, len) +HV* stash; +char* name; +STRLEN len; +{ + static char autoload[] = "AUTOLOAD"; + static STRLEN autolen = 8; + 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, 0))) + return Nullgv; + cv = GvCV(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); + if (!isGV(vargv)) + gv_init(vargv, varstash, autoload, autolen, FALSE); + varsv = GvSV(vargv); + sv_setpv(varsv, HvNAME(stash)); + sv_catpvn(varsv, "::", 2); + sv_catpvn(varsv, name, len); + SvTAINTED_off(varsv); return gv; } @@ -315,7 +341,7 @@ I32 create; #ifdef VMS warn("Weird package name \"%s\" truncated", name); #else - warn("Weird package name \"%.*s...\" truncated", namelen, name); + warn("Weird package name \"%.*s...\" truncated", (int)namelen, name); #endif } Copy(name,tmpbuf,namelen,char); @@ -465,7 +491,7 @@ I32 sv_type; sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); - if (GvCV(*gvp)) + if (GvCVu(*gvp)) warn("(Did you mean &%s instead?)\n", name); stash = 0; } @@ -610,6 +636,14 @@ I32 sv_type; sv_setpv(GvSV(gv),chopset); goto magicalize; + case '?': + if (len > 1) + break; +#ifdef COMPLEX_STATUS + sv_upgrade(GvSV(gv), SVt_PVLV); +#endif + goto magicalize; + case '#': case '*': if (dowarn && len == 1 && sv_type == SVt_PV) @@ -617,7 +651,6 @@ I32 sv_type; /* FALL THROUGH */ case '[': case '!': - case '?': case '^': case '~': case '=': @@ -675,10 +708,11 @@ I32 sv_type; break; case ']': if (len == 1) { - SV *sv; - sv = GvSV(gv); + SV *sv = GvSV(gv); sv_upgrade(sv, SVt_PVNV); sv_setpv(sv, patchlevel); + (void)sv_2nv(sv); + SvREADONLY_on(sv); } break; } @@ -686,38 +720,50 @@ I32 sv_type; } void -gv_fullname(sv,gv) +gv_fullname3(sv, gv, prefix) SV *sv; GV *gv; +char *prefix; { HV *hv = GvSTASH(gv); - - if (!hv) + if (!hv) { + SvOK_off(sv); return; - sv_setpv(sv, sv == (SV*)gv ? "*" : ""); + } + sv_setpv(sv, prefix ? prefix : ""); sv_catpv(sv,HvNAME(hv)); sv_catpvn(sv,"::", 2); sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void -gv_efullname(sv,gv) +gv_efullname3(sv, gv, prefix) SV *sv; GV *gv; +char *prefix; { - GV* egv = GvEGV(gv); - HV *hv; - + GV *egv = GvEGV(gv); if (!egv) egv = gv; - hv = GvSTASH(egv); - if (!hv) - return; + gv_fullname3(sv, egv, prefix); +} - sv_setpv(sv, sv == (SV*)gv ? "*" : ""); - sv_catpv(sv,HvNAME(hv)); - sv_catpvn(sv,"::", 2); - sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv)); +/* XXX compatibility with versions <= 5.003. */ +void +gv_fullname(sv,gv) +SV *sv; +GV *gv; +{ + gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); +} + +/* XXX compatibility with versions <= 5.003. */ +void +gv_efullname(sv,gv) +SV *sv; +GV *gv; +{ + gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); } IO * @@ -786,8 +832,19 @@ gp_ref(gp) GP* gp; { gp->gp_refcnt++; + if (gp->gp_cv) { + if (gp->gp_cvgen) { + /* multi-named GPs cannot be used for method cache */ + SvREFCNT_dec(gp->gp_cv); + gp->gp_cv = Nullcv; + gp->gp_cvgen = 0; + } + else { + /* Adding a new name to a subroutine invalidates method cache */ + sub_generation++; + } + } return gp; - } void @@ -803,6 +860,10 @@ GV* gv; warn("Attempt to free unreferenced glob pointers"); return; } + if (gp->gp_cv) { + /* Deleting the name of a subroutine invalidates method cache */ + sub_generation++; + } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; @@ -813,8 +874,7 @@ GV* gv; SvREFCNT_dec(gp->gp_av); SvREFCNT_dec(gp->gp_hv); SvREFCNT_dec(gp->gp_io); - if ((cv = gp->gp_cv) && !GvCVGEN(gv)) - SvREFCNT_dec(cv); + SvREFCNT_dec(gp->gp_cv); SvREFCNT_dec(gp->gp_form); Safefree(gp); @@ -858,14 +918,14 @@ HV* stash; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; + AMT amt; - if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && - amtp->was_ok_sub == sub_generation) - return HV_AMAGIC(stash)? TRUE: FALSE; - gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); - if (amtp && amtp->table) { + if (mg && amtp->was_ok_am == amagic_generation + && amtp->was_ok_sub == sub_generation) + return AMT_AMAGIC(amtp); + if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; - for (i=1;itable[i]) { SvREFCNT_dec(amtp->table[i]); } @@ -875,38 +935,32 @@ HV* stash; DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); + amt.was_ok_am = amagic_generation; + amt.was_ok_sub = sub_generation; + amt.fallback = AMGfallNO; + amt.flags = 0; + +#ifdef OVERLOAD_VIA_HASH + gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE); /* A shortcut */ if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) { int filled=0; int i; char *cp; - AMT amt; SV* sv; SV** svp; - GV** gvp; - -/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) { - DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash)) -); - return HV_AMAGIC(stash)? TRUE: FALSE; - }*/ - - amt.was_ok_am=amagic_generation; - amt.was_ok_sub=sub_generation; - amt.fallback=AMGfallNO; /* Work with "fallback" key, which we assume to be first in AMG_names */ - if ((cp=((char**)(*AMG_names))[0]) && - (svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { + if (( cp = (char *)AMG_names[0] ) && + (svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) { if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; } - - for (i=1;img_ptr)->table)) + && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ @@ -1066,7 +1185,9 @@ int flags; if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) - && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table)) + && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + ? (amtp = (AMT*)mg->mg_ptr)->table + : NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1103,15 +1224,17 @@ int flags; goto not_found; } } else { - not_found: /* No method found, either report or die */ + not_found: /* No method found, either report or croak */ if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; } else { - if (off==-1) off=method; - sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s", - ((char**)AMG_names)[method + assignshift], + if (off==-1) off=method; + sprintf(buf, + "Operation `%s': no method found,%sargument %s%.256s%s%.256s", + AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -1119,27 +1242,30 @@ int flags; HvNAME(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? - "in overloaded package ": - "has no overloaded magic", + ",\n\tright argument in overloaded package ": + (flags & AMGf_unary + ? "" + : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): ""); if (amtp && amtp->fallback >= AMGfallYES) { DEBUG_o( deb(buf) ); } else { - die(buf); + croak(buf); } return NULL; } } } if (!notfound) { - DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", - ((char**)AMG_names)[off], + DEBUG_o( deb( + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", + AMG_names[off], method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - ((char**)AMG_names)[method+assignshift], + AMG_names[method+assignshift], method+assignshift==off? "" : "')", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", @@ -1177,7 +1303,7 @@ int flags; PUSHs(lr>0? left: right); PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no)); if (notfound) { - PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) ); + PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); } PUSHs((SV*)cv); PUTBACK; @@ -1190,11 +1316,6 @@ int flags; res=POPs; PUTBACK; - if (notfound) { - /* sv_2mortal(res); */ - return NULL; - } - if (postpr) { int ans; switch (method) { @@ -1218,14 +1339,14 @@ int flags; ans=SvIV(res)!=0; break; case inc_amg: case dec_amg: - SvSetSV(left,res); return res; break; + SvSetSV(left,res); return left; case not_amg: -ans=!SvOK(res); break; + ans=!SvOK(res); break; } return ans? &sv_yes: &sv_no; } else if (method==copy_amg) { if (!SvROK(res)) { - die("Copy method did not return a reference"); + croak("Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else {