X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/724421654fcf33f3acf0a7b8f4356b9255c9265a..1d3434b8c1ecb43ba830424cfca969ab84444ed7:/gv.c diff --git a/gv.c b/gv.c index fed7eca..b48e4d8 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. @@ -22,8 +22,7 @@ EXT char rcsid[]; GV * -gv_AVadd(gv) -register GV *gv; +gv_AVadd(register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for array"); @@ -33,8 +32,7 @@ register GV *gv; } GV * -gv_HVadd(gv) -register GV *gv; +gv_HVadd(register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for hash"); @@ -44,8 +42,7 @@ register GV *gv; } GV * -gv_IOadd(gv) -register GV *gv; +gv_IOadd(register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) croak("Bad symbol for filehandle"); @@ -55,54 +52,89 @@ register GV *gv; } GV * -gv_fetchfile(name) -char *name; +gv_fetchfile(char *name) { - char tmpbuf[1200]; + dTHR; + 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"))) + if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) GvMULTI_on(gv); - if (perldb) + if (PERLDB_LINE) hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; } void -gv_init(gv, stash, name, len, multi) -GV *gv; -HV *stash; -char *name; -STRLEN len; -int multi; +gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) { + dTHR; 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)) - Safefree(SvPVX(gv)); - Newz(602,gp, 1, GP); + 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); - GvREFCNT(gv) = 1; GvSV(gv) = NEWSV(72,0); GvLINE(gv) = curcop->cop_line; GvFILEGV(gv) = curcop->cop_filegv; GvEGV(gv) = gv; sv_magic((SV*)gv, (SV*)gv, '*', name, len); - GvSTASH(gv) = stash; + GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; if (multi) GvMULTI_on(gv); + if (doproto) { /* Replicate part of newSUB here. */ + ENTER; + start_subparse(0,0); /* Create CV in compcv. */ + GvCV(gv) = compcv; + LEAVE; + + GvCVGEN(gv) = 0; + sub_generation++; + CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); + CvFILEGV(GvCV(gv)) = curcop->cop_filegv; + CvSTASH(GvCV(gv)) = curstash; +#ifdef USE_THREADS + CvOWNER(GvCV(gv)) = 0; + 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); + } + } } static void -gv_init_sv(gv, sv_type) -GV* gv; -I32 sv_type; +gv_init_sv(GV *gv, I32 sv_type) { switch (sv_type) { case SVt_PVIO: @@ -118,49 +150,70 @@ I32 sv_type; } GV * -gv_fetchmeth(stash, name, len, level) -HV* stash; -char* name; -STRLEN len; -I32 level; +gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) { AV* av; 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 (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))) { + gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); + av = (gvp && (gv = *gvp) && gv != (GV*)&sv_undef) ? GvAV(gv) : Nullav; + + /* create and re-create @.*::SUPER::ISA on demand */ + if (!av || !SvMAGIC(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))) { + dTHR; /* just for SvREFCNT_dec */ + 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); + } + } + } + + if (av) { SV** svp = AvARRAY(av); - I32 items = AvFILL(av) + 1; + /* NOTE: No support for tied ISA */ + I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); @@ -170,30 +223,37 @@ 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 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 + 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: + /* + * 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; } - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ return gv; } } @@ -203,126 +263,140 @@ I32 level; } GV * -gv_fetchmethod(stash, name) -HV* stash; -char* name; +gv_fetchmethod(HV *stash, char *name) +{ + return gv_fetchmethod_autoload(stash, name, TRUE); +} + +GV * +gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload) { + dTHR; 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'; - if (strEQ(origname,"SUPER")) { - /* Degenerate case ->SUPER::method should really lookup in original stash */ - SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0)); - sv_catpvn(tmpstr, "::SUPER", 7); - stash = gv_stashpvn(SvPVX(tmpstr),SvCUR(tmpstr),TRUE); - *nsplit = ch; - DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) ); - } else { - stash = gv_stashpvn(origname, nsplit - 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) ); } - } - gv = gv_fetchmeth(stash, name, nend - name, 0); - - if (!gv) { - /* Failed obvious case - look for SUPER as last element of stash's name */ - char *packname = HvNAME(stash); - STRLEN len = strlen(packname); - 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 - */ - HV *basestash; - char ch = packname[len]; - AV *av; - packname[len] = '\0'; - basestash = gv_stashpvn(packname, len, TRUE); - packname[len] = ch; - gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE); - if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { - /* Okay found @ISA after dropping the SUPER, alias it */ - SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); - sv_catpvn(tmpstr, "::ISA", 5); - gv = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV); - if (gv) { - GvAV(gv) = (AV*)SvREFCNT_inc(av); - /* ... and re-try lookup */ - gv = gv_fetchmeth(stash, name, nend - name, 0); - } else { - croak("Cannot create %s::ISA",HvNAME(stash)); - } - } - } - } + else + stash = gv_stashpvn(origname, nsplit - origname, TRUE); } + gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { - CV* cv; - 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); - SvTAINTED_off(GvSV(CvGV(cv))); + 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(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; } HV* -gv_stashpv(name,create) -char *name; -I32 create; +gv_stashpv(char *name, I32 create) { return gv_stashpvn(name, strlen(name), create); } HV* -gv_stashpvn(name,namelen,create) -char *name; -U32 namelen; -I32 create; +gv_stashpvn(char *name, U32 namelen, I32 create) { - char tmpbuf[1203]; + char smallbuf[256]; + char *tmpbuf; HV *stash; GV *tmpgv; - if (namelen > 1200) { - namelen = 1200; -#ifdef VMS - warn("Weird package name \"%s\" truncated", name); -#else - warn("Weird package name \"%.*s...\" truncated", namelen, name); -#endif - } + 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); + tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); + if (tmpbuf != smallbuf) + Safefree(tmpbuf); if (!tmpgv) return 0; if (!GvHV(tmpgv)) @@ -334,9 +408,7 @@ I32 create; } HV* -gv_stashsv(sv,create) -SV *sv; -I32 create; +gv_stashsv(SV *sv, I32 create) { register char *ptr; STRLEN len; @@ -346,19 +418,16 @@ I32 create; GV * -gv_fetchpv(nambeg,add,sv_type) -char *nambeg; -I32 add; -I32 sv_type; +gv_fetchpv(char *nambeg, I32 add, I32 sv_type) { + dTHR; register char *name = nambeg; register GV *gv = 0; GV**gvp; I32 len; register char *namend; HV *stash = 0; - bool global = FALSE; - char *tmpbuf; + U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -374,23 +443,29 @@ I32 sv_type; len = namend - name; if (len > 0) { - New(601, tmpbuf, len+3, char); + char *tmpbuf; + char autobuf[64]; + + if (len < sizeof(autobuf) - 2) + tmpbuf = autobuf; + else + New(601, tmpbuf, len+3, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); - Safefree(tmpbuf); - if (!gvp || *gvp == (GV*)&sv_undef) - return Nullgv; - gv = *gvp; - - if (SvTYPE(gv) == SVt_PVGV) - GvMULTI_on(gv); - else if (!add) + gv = gvp ? *gvp : Nullgv; + if (gv && gv != (GV*)&sv_undef) { + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, tmpbuf, len, (add & 2)); + else + GvMULTI_on(gv); + } + if (tmpbuf != autobuf) + Safefree(tmpbuf); + if (!gv || gv == (GV*)&sv_undef) return Nullgv; - else - gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); @@ -415,6 +490,8 @@ I32 sv_type; if (!stash) { if (isIDFIRST(*name)) { + bool global = FALSE; + if (isUPPER(*name)) { if (*name > 'I') { if (*name == 'S' && ( @@ -439,6 +516,7 @@ I32 sv_type; } else if (*name == '_' && !name[1]) global = TRUE; + if (global) stash = defstash; else if ((COP*)curcop == &compiling) { @@ -465,7 +543,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; } @@ -481,13 +559,26 @@ I32 sv_type; /* By this point we should have a stash and a name */ if (!stash) { - if (add) { - warn("Global symbol \"%s\" requires explicit package name", name); - ++error_count; - stash = curstash ? curstash : defstash; /* avoid core dumps */ - } - else + if (!add) return Nullgv; + if (add & ~2) { + char sv_type_char = ((sv_type == SVt_PV) ? '$' + : (sv_type == SVt_PVAV) ? '@' + : (sv_type == SVt_PVHV) ? '%' + : 0); + if (sv_type_char) + warn("Global symbol \"%c%s\" requires explicit package name", + sv_type_char, name); + else + 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); } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -503,14 +594,17 @@ I32 sv_type; gv_init_sv(gv, sv_type); } return gv; + } else if (add & GV_NOINIT) { + return gv; } /* Adding a new symbol */ - if (add & 4) + if (add & GV_ADDWARN) warn("Had to create %s unexpectedly", nambeg); - gv_init(gv, stash, name, len, add & 2); + gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); + GvFLAGS(gv) |= add_gvflags; /* set up magic where warranted */ switch (*name) { @@ -534,7 +628,9 @@ I32 sv_type; AV* av = GvAVn(gv); GvMULTI_on(gv); sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); - if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1) + /* NOTE: No support for tied ISA */ + if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") + && AvFILLp(av) == -1) { char *pname; av_push(av, newSVpv(pname = "NDBM_File",0)); @@ -555,7 +651,7 @@ I32 sv_type; if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); GvMULTI_on(gv); - sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0); + hv_magic(hv, gv, 'A'); } break; #endif /* OVERLOAD */ @@ -575,11 +671,6 @@ I32 sv_type; psig_ptr[i] = 0; psig_name[i] = 0; } - /* initialize signal stack */ - signalstack = newAV(); - AvREAL_off(signalstack); - av_extend(signalstack, 30); - av_fill(signalstack, 0); } break; @@ -610,14 +701,36 @@ 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 '!': + if(len > 1) + break; + if(sv_type > SVt_PV) { + HV* stash = gv_stashpvn("Errno",5,FALSE); + if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + dSP; + PUTBACK; + perl_require_pv("Errno.pm"); + SPAGAIN; + stash = gv_stashpvn("Errno",5,FALSE); + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) + croak("Can't use %%! because Errno.pm is not avaliable"); + } + } + goto magicalize; case '#': case '*': if (dowarn && len == 1 && sv_type == SVt_PV) warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': - case '!': - case '?': case '^': case '~': case '=': @@ -656,6 +769,7 @@ I32 sv_type; case '7': case '8': case '9': + case '\023': ro_magicalize: SvREADONLY_on(GvSV(gv)); magicalize: @@ -675,10 +789,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,10 +801,7 @@ I32 sv_type; } void -gv_fullname3(sv, gv, prefix) -SV *sv; -GV *gv; -char *prefix; +gv_fullname3(SV *sv, GV *gv, char *prefix) { HV *hv = GvSTASH(gv); if (!hv) { @@ -703,10 +815,7 @@ char *prefix; } void -gv_efullname3(sv, gv, prefix) -SV *sv; -GV *gv; -char *prefix; +gv_efullname3(SV *sv, GV *gv, char *prefix) { GV *egv = GvEGV(gv); if (!egv) @@ -716,25 +825,22 @@ char *prefix; /* XXX compatibility with versions <= 5.003. */ void -gv_fullname(sv,gv) -SV *sv; -GV *gv; +gv_fullname(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_efullname(SV *sv, GV *gv) { gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); } IO * -newIO() +newIO(void) { + dTHR; IO *io; GV *iogv; @@ -742,15 +848,17 @@ newIO() sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); - iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); + iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); + if (!iogv) + iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } void -gv_check(stash) -HV* stash; +gv_check(HV *stash) { + dTHR; register HE *entry; register I32 i; register GV *gv; @@ -769,7 +877,7 @@ HV* stash; } else if (isALPHA(*HeKEY(entry))) { gv = (GV*)HeVAL(entry); - if (GvMULTI(gv)) + if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); @@ -784,27 +892,35 @@ HV* stash; } GV * -newGVgen(pack) -char *pack; +newGVgen(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 */ GP* -gp_ref(gp) -GP* gp; +gp_ref(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; +gp_free(GV *gv) { GP* gp; CV* cv; @@ -815,6 +931,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; @@ -825,8 +945,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); @@ -861,23 +980,23 @@ register GV *gv; /* Updates and caches the CV's */ bool -Gv_AMupdate(stash) -HV* stash; +Gv_AMupdate(HV *stash) { + dTHR; GV** gvp; HV* hv; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); - AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL; + AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) 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]); } @@ -887,38 +1006,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 + : (CV **) NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ @@ -1027,13 +1193,11 @@ int flags; case copy_amg: { SV* ref=SvRV(left); - if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be - * extra - * causious, - * maybe in some - * additional - * cases sv_setsv - * is safe too */ + 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)); @@ -1078,7 +1242,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 + : (CV **) NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1088,7 +1254,7 @@ int flags; && !(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 */ @@ -1115,15 +1281,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 { - 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], + 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", @@ -1131,27 +1300,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) ); + DEBUG_o( deb("%s", SvPVX(msg)) ); } else { - die(buf); + croak("%_", msg); } 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 %s%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", @@ -1170,42 +1342,41 @@ int flags; 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; + PUSHSTACK(SI_OVERLOAD); ENTER; - SAVESPTR(op); + SAVEOP(); op = (OP *) &myop; - if (perldb && curstash != debstash) + if (PERLDB_SUB && curstash != debstash) op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(); + pp_pushmark(ARGS); - EXTEND(sp, notfound + 5); + 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)[method + assignshift],0)) ); + PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); } PUSHs((SV*)cv); PUTBACK; - if (op = pp_entersub()) + if (op = pp_entersub(ARGS)) runops(); LEAVE; SPAGAIN; res=POPs; - PUTBACK; - - if (notfound) { - /* sv_2mortal(res); */ - return NULL; - } + POPSTACK(); + CATCH_SET(oldcatch); if (postpr) { int ans; @@ -1232,12 +1403,12 @@ int flags; case dec_amg: SvSetSV(left,res); return left; case not_amg: -ans=!SvOK(res); break; + ans=!SvOK(res); break; } - return ans? &sv_yes: &sv_no; + return boolSV(ans); } 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 { @@ -1246,3 +1417,4 @@ ans=!SvOK(res); break; } } #endif /* OVERLOAD */ +