X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=6c912a0e9b365aa3e1e9e95275ab0308d341d4cd;hb=7cb3fdbc2b45d54cfc6aac117f89b42d632cb3ed;hp=3a9b8259116f764c9ed5bf6e75eaa7e1e4498efa;hpb=a0d0e21ea6ea90a22318550944fe6cb09ae10cda;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 3a9b825..6c912a0 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -19,7 +19,7 @@ #include "EXTERN.h" #include "perl.h" -extern char rcsid[]; +EXT char rcsid[]; GV * gv_AVadd(gv) @@ -58,14 +58,27 @@ GV * gv_fetchfile(name) char *name; { - char tmpbuf[1200]; + char smallbuf[256]; + char *tmpbuf; + STRLEN tmplen; GV *gv; - sprintf(tmpbuf,"::_<%s", name); - gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV); + tmplen = strlen(name) + 2; + if (tmplen < sizeof smallbuf) + tmpbuf = smallbuf; + else + New(603, tmpbuf, tmplen + 1, char); + tmpbuf[0] = '_'; + tmpbuf[1] = '<'; + strcpy(tmpbuf + 2, name); + gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); + if (!isGV(gv)) + gv_init(gv, defstash, tmpbuf, tmplen, FALSE); + if (tmpbuf != smallbuf) + Safefree(tmpbuf); sv_setpv(GvSV(gv), name); - if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm"))) - SvMULTI_on(gv); + if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) + GvMULTI_on(gv); if (perldb) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; @@ -81,12 +94,11 @@ int multi; { register GP *gp; - sv_upgrade(gv, SVt_PVGV); + 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; @@ -96,7 +108,7 @@ int multi; GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) - SvMULTI_on(gv); + GvMULTI_on(gv); } static void @@ -128,27 +140,60 @@ I32 level; GV* topgv; GV* gv; GV** gvp; - HV* lastchance; + CV* cv; 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 (GvCV(topgv)) { - if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation) - return topgv; + 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; + } + } + + gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); + av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav; + + /* create @.*::SUPER::ISA on demand */ + if (!av) { + char* packname = HvNAME(stash); + STRLEN packlen = strlen(packname); + + if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { + HV* basestash; + + packlen -= 7; + basestash = gv_stashpvn(packname, packlen, TRUE); + gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE); + if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); + if (!gvp || !(gv = *gvp)) + croak("Cannot create %s::ISA", HvNAME(stash)); + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, "ISA", 3, TRUE); + SvREFCNT_dec(GvAV(gv)); + GvAV(gv) = (AV*)SvREFCNT_inc(av); + } + } } - gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); - if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { + if (av) { SV** svp = AvARRAY(av); I32 items = AvFILL(av) + 1; while (items--) { @@ -160,20 +205,37 @@ I32 level; SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len, level + 1); - if (gv) { - 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 (lastchance = gv_stashpv("UNIVERSAL", FALSE)) { - if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ + /* if at top level, try UNIVERSAL */ + + if (level == 0 || level == -1) { + HV* lastchance; + + if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { + if (gv = gv_fetchmeth(lastchance, name, len, + (level >= 0) ? level + 1 : level - 1)) { + gotcha: + /* + * Cache method in topgv if: + * 1. topgv has no synonyms (else inheritance crosses wires) + * 2. method isn't a stub (else AUTOLOAD fails spectacularly) + */ + if (topgv && + GvREFCNT(topgv) == 1 && + (cv = GvCV(gv)) && + (CvROOT(cv) || CvXSUB(cv))) + { + if (cv = GvCV(topgv)) + SvREFCNT_dec(cv); + GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); + GvCVGEN(topgv) = sub_generation; + } return gv; } } @@ -187,42 +249,116 @@ gv_fetchmethod(stash, name) HV* stash; char* name; { + return gv_fetchmethod_autoload(stash, name, TRUE); +} + +GV * +gv_fetchmethod_autoload(stash, name, autoload) +HV* stash; +char* name; +I32 autoload; +{ register char *nend; char *nsplit = 0; GV* gv; for (nend = name; *nend; nend++) { - if (*nend == ':' || *nend == '\'') + if (*nend == '\'') nsplit = nend; + else if (*nend == ':' && *(nend + 1) == ':') + nsplit = ++nend; } if (nsplit) { - char ch; char *origname = name; name = nsplit + 1; - ch = *nsplit; if (*nsplit == ':') --nsplit; - *nsplit = '\0'; - stash = gv_stashpv(origname,TRUE); - *nsplit = ch; + if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { + /* ->SUPER::method should really be looked up in original stash */ + SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER", + HvNAME(curcop->cop_stash))); + stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); + DEBUG_o( deb("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) { - CV* cv; - - if (strEQ(name,"import") || strEQ(name,"unimport")) - 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_newmortal(); - sv_catpv(tmpstr,HvNAME(stash)); - sv_catpvn(tmpstr,"::", 2); - sv_catpvn(tmpstr, name, nend - name); - sv_setsv(GvSV(CvGV(cv)), tmpstr); + if (strEQ(name,"import")) + gv = (GV*)&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; +} + +GV* +gv_autoload4(stash, name, len, method) +HV* stash; +char* name; +STRLEN len; +I32 method; +{ + 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, FALSE))) + return Nullgv; + cv = GvCV(gv); + + /* + * Inheriting AUTOLOAD for non-methods works ... for now. + */ + if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) + warn( + "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); + 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; } @@ -231,11 +367,31 @@ gv_stashpv(name,create) char *name; I32 create; { - char tmpbuf[1234]; + return gv_stashpvn(name, strlen(name), create); +} + +HV* +gv_stashpvn(name,namelen,create) +char *name; +U32 namelen; +I32 create; +{ + char smallbuf[256]; + char *tmpbuf; HV *stash; GV *tmpgv; - sprintf(tmpbuf,"%.*s::",1200,name); - tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV); + + if (namelen + 3 < sizeof smallbuf) + tmpbuf = smallbuf; + else + New(606, tmpbuf, namelen + 3, char); + Copy(name,tmpbuf,namelen,char); + tmpbuf[namelen++] = ':'; + tmpbuf[namelen++] = ':'; + tmpbuf[namelen] = '\0'; + tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); + if (tmpbuf != smallbuf) + Safefree(tmpbuf); if (!tmpgv) return 0; if (!GvHV(tmpgv)) @@ -251,7 +407,10 @@ gv_stashsv(sv,create) SV *sv; I32 create; { - return gv_stashpv(SvPV(sv,na), create); + register char *ptr; + STRLEN len; + ptr = SvPV(sv,len); + return gv_stashpvn(ptr, len, create); } @@ -267,16 +426,19 @@ I32 sv_type; I32 len; register char *namend; HV *stash = 0; - bool global = FALSE; + U32 add_gvflags = 0; char *tmpbuf; + if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ + name++; + for (namend = name; *namend; namend++) { if ((*namend == '\'' && namend[1]) || (*namend == ':' && namend[1] == ':')) { if (!stash) stash = defstash; - if (!SvREFCNT(stash)) /* symbol table under destruction */ + if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ return Nullgv; len = namend - name; @@ -293,7 +455,7 @@ I32 sv_type; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) - SvMULTI_on(gv); + GvMULTI_on(gv); else if (!add) return Nullgv; else @@ -311,7 +473,7 @@ I32 sv_type; namend++; name = namend; if (!*name) - return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE); + return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE); } } len = namend - name; @@ -322,6 +484,8 @@ I32 sv_type; if (!stash) { if (isIDFIRST(*name)) { + bool global = FALSE; + if (isUPPER(*name)) { if (*name > 'I') { if (*name == 'S' && ( @@ -346,13 +510,37 @@ I32 sv_type; } else if (*name == '_' && !name[1]) global = TRUE; + if (global) stash = defstash; else if ((COP*)curcop == &compiling) { stash = curstash; - if (add && (hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV) { - if (stash && !hv_fetch(stash,name,len,0)) + if (add && (hints & HINT_STRICT_VARS) && + sv_type != SVt_PVCV && + sv_type != SVt_PVGV && + sv_type != SVt_PVFM && + sv_type != SVt_PVIO && + !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) ) + { + gvp = (GV**)hv_fetch(stash,name,len,0); + if (!gvp || + *gvp == (GV*)&sv_undef || + SvTYPE(*gvp) != SVt_PVGV) + { stash = 0; + } + else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) || + sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) || + sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) ) + { + warn("Variable \"%c%s\" is not imported", + sv_type == SVt_PVAV ? '@' : + sv_type == SVt_PVHV ? '%' : '$', + name); + if (GvCVu(*gvp)) + warn("(Did you mean &%s instead?)\n", name); + stash = 0; + } } } else @@ -369,6 +557,10 @@ I32 sv_type; warn("Global symbol \"%s\" requires explicit package name", name); ++error_count; stash = curstash ? curstash : defstash; /* avoid core dumps */ + add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV + : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV + : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV + : 0); } else return Nullgv; @@ -383,7 +575,7 @@ I32 sv_type; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { - SvMULTI_on(gv); + GvMULTI_on(gv); gv_init_sv(gv, sv_type); } return gv; @@ -395,6 +587,7 @@ I32 sv_type; warn("Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & 2); gv_init_sv(gv, sv_type); + GvFLAGS(gv) |= add_gvflags; /* set up magic where warranted */ switch (*name) { @@ -407,30 +600,30 @@ I32 sv_type; case 'a': case 'b': if (len == 1) - SvMULTI_on(gv); + GvMULTI_on(gv); break; case 'E': if (strnEQ(name, "EXPORT", 6)) - SvMULTI_on(gv); + GvMULTI_on(gv); break; case 'I': if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); - SvMULTI_on(gv); + GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); - gv_stashpv(pname, TRUE); + gv_stashpvn(pname, 9, TRUE); av_push(av, newSVpv(pname = "DB_File",0)); - gv_stashpv(pname, TRUE); + gv_stashpvn(pname, 7, TRUE); av_push(av, newSVpv(pname = "GDBM_File",0)); - gv_stashpv(pname, TRUE); + gv_stashpvn(pname, 9, TRUE); av_push(av, newSVpv(pname = "SDBM_File",0)); - gv_stashpv(pname, TRUE); + gv_stashpvn(pname, 9, TRUE); av_push(av, newSVpv(pname = "ODBM_File",0)); - gv_stashpv(pname, TRUE); + gv_stashpvn(pname, 9, TRUE); } } break; @@ -438,7 +631,7 @@ I32 sv_type; case 'O': if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); - SvMULTI_on(gv); + GvMULTI_on(gv); sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); } break; @@ -446,11 +639,19 @@ I32 sv_type; case 'S': if (strEQ(name, "SIG")) { HV *hv; + I32 i; siggv = gv; - SvMULTI_on(siggv); + GvMULTI_on(siggv); hv = GvHVn(siggv); hv_magic(hv, siggv, 'S'); - + for(i=1;sig_name[i];i++) { + SV ** init; + init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1); + if(init) + sv_setsv(*init,&sv_undef); + psig_ptr[i] = 0; + psig_name[i] = 0; + } /* initialize signal stack */ signalstack = newAV(); AvREAL_off(signalstack); @@ -486,6 +687,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) @@ -493,7 +702,6 @@ I32 sv_type; /* FALL THROUGH */ case '[': case '!': - case '?': case '^': case '~': case '=': @@ -508,13 +716,16 @@ I32 sv_type; case '\\': case '/': case '|': + case '\001': case '\004': + case '\005': + case '\006': case '\010': + case '\017': case '\t': case '\020': case '\024': case '\027': - case '\006': if (len > 1) break; goto magicalize; @@ -548,10 +759,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; } @@ -559,34 +771,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 = GvSTASH(egv); + GV *egv = GvEGV(gv); + if (!egv) + egv = gv; + gv_fullname3(sv, egv, prefix); +} - if (!hv) - return; - 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 * @@ -599,7 +827,7 @@ newIO() sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO); + iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } @@ -617,23 +845,23 @@ HV* stash; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { - for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) { - if (entry->hent_key[entry->hent_klen-1] == ':' && - (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv)) + for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && + (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) { if (hv != defstash) gv_check(hv); /* nested package */ } - else if (isALPHA(*entry->hent_key)) { - gv = (GV*)entry->hent_val; - if (SvMULTI(gv)) + else if (isALPHA(*HeKEY(entry))) { + gv = (GV*)HeVAL(entry); + if (GvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); curcop->cop_filegv = filegv; - if (filegv && SvMULTI(filegv)) /* Filename began with slash */ + if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; - warn("Identifier \"%s::%s\" used only once: possible typo", + warn("Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } @@ -644,8 +872,8 @@ GV * newGVgen(pack) char *pack; { - (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++); - return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV); + return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++), + TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ @@ -655,17 +883,27 @@ 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 gp_free(gv) GV* gv; { - IO *io; - CV *cv; GP* gp; + CV* cv; if (!gv || !(gp = GvGP(gv))) return; @@ -673,18 +911,23 @@ GV* gv; warn("Attempt to free unreferenced glob pointers"); return; } - if (--gp->gp_refcnt > 0) + 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; return; + } SvREFCNT_dec(gp->gp_sv); SvREFCNT_dec(gp->gp_av); SvREFCNT_dec(gp->gp_hv); - if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) { - do_close(gv,FALSE); - SvREFCNT_dec(io); - } - if ((cv = gp->gp_cv) && !GvCVGEN(gv)) - SvREFCNT_dec(cv); + SvREFCNT_dec(gp->gp_io); + SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec(gp->gp_form); + Safefree(gp); GvGP(gv) = 0; } @@ -725,53 +968,56 @@ HV* stash; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); - AMT *amtp; + 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 (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]); + } + } + } sv_unmagic((SV*)stash, 'c'); 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; -/* 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;icop_stash, SvPV(sv, na)); + gv = gv_fetchmethod(stash, SvPV(sv, na)); if (gv) cv = GvCV(gv); break; } @@ -781,35 +1027,92 @@ HV* stash; /* FALL THROUGH */ case SVt_PVHV: case SVt_PVAV: - die("Not a subroutine reference in %%OVERLOAD"); + croak("Not a subroutine reference in overload table"); return FALSE; case SVt_PVCV: - cv = (CV*)sv; - break; + cv = (CV*)sv; + break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, TRUE); - break; + if (!(cv = GvCVu((GV*)sv))) + cv = sv_2cv(sv, &stash, &gv, TRUE); + break; } if (cv) filled=1; else { - die("Method for operation %s not found in package %s during blessing\n", + croak("Method for operation %s not found in package %.256s during blessing\n", cp,HvNAME(stash)); return FALSE; } } - } - amt.table[i]=cv; +#else + { + int filled = 0; + int i; + const char *cp; + SV* sv = NULL; + SV** svp; + + /* Work with "fallback" key, which we assume to be first in AMG_names */ + + if ( cp = AMG_names[0] ) { + /* Try to find via inheritance. */ + gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ + if (gv) sv = GvSV(gv); + + if (!gv) goto no_table; + else if (SvTRUE(sv)) amt.fallback=AMGfallYES; + else if (SvOK(sv)) amt.fallback=AMGfallNEVER; + } + + for (i = 1; i < NofAMmeth; i++) { + SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i])); + DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", + cp, HvNAME(stash)) ); + /* don't fill the cache while looking up! */ + gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + cv = 0; + if(gv && (cv = GvCV(gv))) { + if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") + && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + /* GvSV contains the name of the method. */ + GV *ngv; + + DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", + SvPV(GvSV(gv), na), cp, HvNAME(stash)) ); + if (!SvPOK(GvSV(gv)) + || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), + FALSE))) + { + /* Can be an import stub (created by `can'). */ + if (GvCVGEN(gv)) { + croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } else + croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", + (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), + cp, HvNAME(stash)); + } + cv = GvCV(gv = ngv); + } + DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", + cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + GvNAME(CvGV(cv))) ); + filled = 1; + } +#endif + amt.table[i]=(CV*)SvREFCNT_inc(cv); } - sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt)); if (filled) { -/* HV_badAMAGIC_off(stash);*/ - HV_AMAGIC_on(stash); + AMT_AMAGIC_on(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); return TRUE; } } -/*HV_badAMAGIC_off(stash);*/ - HV_AMAGIC_off(stash); + /* Here we have no table: */ + no_table: + AMT_AMAGIC_off(&amt); + sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); return FALSE; } @@ -828,17 +1131,17 @@ int flags; CV **cvp=NULL, **ocvp=NULL; AMT *amtp, *oamtp; int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; - int postpr=0; + int postpr=0, inc_dec_ass=0, assignshift=assign?1:0; HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) - && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table)) - && (assign ? - ((cv = cvp[off=method+1]) - || ( amtp->fallback > AMGfallNEVER && /* fallback to - * usual method */ - (fl = 1, cv = cvp[off=method]))): - (1 && (cv = cvp[off=method])) )) { + && (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 */ + (fl = 1, cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -847,13 +1150,13 @@ int flags; /* look for substituted methods */ switch (method) { case inc_amg: - if ((cv = cvp[off=add_ass_amg]) + if (((cv = cvp[off=add_ass_amg]) && (inc_dec_ass=1)) || ((cv = cvp[off=add_amg]) && (postpr=1))) { right = &sv_yes; lr = -1; assign = 1; } break; case dec_amg: - if ((cv = cvp[off=subtr_ass_amg]) + if (((cv = cvp[off=subtr_ass_amg]) && (inc_dec_ass=1)) || ((cv = cvp[off=subtr_amg]) && (postpr=1))) { right = &sv_yes; lr = -1; assign = 1; } @@ -867,24 +1170,44 @@ int flags; case string_amg: (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; + case not_amg: + (void)((cv = cvp[off=bool__amg]) + || (cv = cvp[off=numer_amg]) + || (cv = cvp[off=string_amg])); + postpr = 1; + break; + case copy_amg: + { + SV* ref=SvRV(left); + if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { + /* + * Just to be extra cautious. Maybe in some + * additional cases sv_setsv is safe, too. + */ + SV* newref = newSVsv(ref); + SvOBJECT_on(newref); + SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref)); + return newref; + } + } + break; case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=lt_amg]) + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { + SV* nullsv=sv_2mortal(newSViv(0)); if (off1==lt_amg) { - SV* lessp = amagic_call(left, - sv_2mortal(newSViv(0)), + SV* lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); logic = SvTRUE(lessp); } else { - SV* lessp = amagic_call(left, - sv_2mortal(newSViv(0)), + SV* lessp = amagic_call(left,nullsv, ncmp_amg,AMGf_noright); logic = (SvNV(lessp) < 0); } if (logic) { if (off==subtr_amg) { right = left; - left = sv_2mortal(newSViv(0)); + left = nullsv; lr = 1; } } else { @@ -905,16 +1228,19 @@ 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; - } else if (((ocvp && oamtp->fallback > AMGfallNEVER && (cvp=ocvp)) + } else if (((ocvp && oamtp->fallback > AMGfallNEVER + && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for * comparison operations and - * concatendation */ + * concatenation */ if (method==concat_amg || method==concat_ass_amg || method==repeat_amg || method==repeat_ass_amg) { return NULL; /* Delegate operation to string conversion */ @@ -941,15 +1267,18 @@ 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 { - char tmpstr[512]; - sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%200s,\n\tright argument %s%200s", - ((char**)AMG_names)[off], + SV *msg; + if (off==-1) off=method; + msg = sv_2mortal(newSVpvf( + "Operation `%s': no method found,%sargument %s%s%s%s", + AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -957,69 +1286,82 @@ 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(tmpstr) ); + DEBUG_o( deb("%s", SvPVX(msg)) ); } else { - die(tmpstr); + croak("%_", msg); } return NULL; } } } if (!notfound) { - DEBUG_o( deb("Operation `%s': method for %s argument found in package %s%s\n", - ((char**)AMG_names)[off], - (lr? "right": "left"), + DEBUG_o( deb( + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + AMG_names[off], + method+assignshift==off? "" : + " (initially `", + method+assignshift==off? "" : + AMG_names[method+assignshift], + method+assignshift==off? "" : "')", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", HvNAME(stash), fl? ",\n\tassignment variant used": "") ); - /* Since we use shallow copy, we need to dublicate the contents, - probably we need also to use user-supplied version of coping? - */ - if (assign || method==inc_amg || method==dec_amg) RvDEEPCP(left); + /* Since we use shallow copy during assignment, we need + * to dublicate the contents, probably calling user-supplied + * version of copy operator + */ + if ((method + assignshift==off + && (assign || method==inc_amg || method==dec_amg)) + || inc_dec_ass) RvDEEPCP(left); } { dSP; BINOP myop; SV* res; + bool oldcatch = CATCH_GET; + CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = Nullop; - myop.op_flags = OPf_KNOW|OPf_STACKED; + myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; ENTER; SAVESPTR(op); op = (OP *) &myop; + if (perldb && curstash != debstash) + op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(); EXTEND(sp, notfound + 5); PUSHs(lr>0? right: left); PUSHs(lr>0? left: right); - PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no)); + PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[off],0)) ); + PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); } PUSHs((SV*)cv); PUTBACK; if (op = pp_entersub()) - run(); + runops(); LEAVE; SPAGAIN; res=POPs; PUTBACK; - - if (notfound) { - /* sv_2mortal(res); */ - return NULL; - } + CATCH_SET(oldcatch); if (postpr) { int ans; @@ -1044,9 +1386,16 @@ 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; + } + return boolSV(ans); + } else if (method==copy_amg) { + if (!SvROK(res)) { + croak("Copy method did not return a reference"); } - return ans? &sv_yes: &sv_no; + return SvREFCNT_inc(SvRV(res)); } else { return res; }