X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=727692b710d3e115375817f4ab992effdd694d0c;hb=3937c24e3f4ed26beafd7a2fbe3a20466bfc2b2d;hp=2e2bc193d53cf10f9d9615033852cbeea7dd299c;hpb=a9bc755754f0db5e848e65dfd2e63a96af50ffd4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 2e2bc19..727692b 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,11 +19,8 @@ #include "EXTERN.h" #include "perl.h" -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 +30,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 +40,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,58 +50,93 @@ 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); - tmplen = strlen(tmpbuf); - gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); + 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(PL_defstash, tmpbuf, tmplen, TRUE); if (!isGV(gv)) - gv_init(gv, defstash, tmpbuf, tmplen, FALSE); + gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + if (tmpbuf != smallbuf) + Safefree(tmpbuf); sv_setpv(GvSV(gv), name); 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; + GvLINE(gv) = PL_curcop->cop_line; + GvFILEGV(gv) = PL_curcop->cop_filegv; + GvCVGEN(gv) = 0; 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. */ + 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*)SvREFCNT_inc(gv); + CvFILEGV(GvCV(gv)) = PL_curcop->cop_filegv; + 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); + } + } } -static void -gv_init_sv(gv, sv_type) -GV* gv; -I32 sv_type; +STATIC void +gv_init_sv(GV *gv, I32 sv_type) { switch (sv_type) { case SVt_PVIO: @@ -122,80 +152,120 @@ 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 = NULL; + GV* topgv; GV* gv; GV** gvp; - HV* lastchance; CV* cv; if (!stash) return 0; if ((level > 100) || (level < -100)) - croak("Recursive inheritance detected"); - - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + croak("Recursive inheritance detected while looking for method '%s' in package '%s'", + name, HvNAME(stash)); DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); - if (!gvp) goto recurse; - - topgv = *gvp; - if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); - if (cv = GvCV(topgv)) { - if (CvXSUB(cv) || CvROOT(cv) || CvGV(cv)) { /* Not deleted, possibly autoloaded. */ - if (GvCVGEN(topgv) >= sub_generation) - return topgv; /* valid cached inheritance */ - if (!GvCVGEN(topgv)) { /* not an inheritance cache */ + 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) == PL_sub_generation) return topgv; + /* Stale cached entry: junk it */ + SvREFCNT_dec(cv); + GvCV(topgv) = cv = Nullcv; + GvCVGEN(topgv) = 0; + } + else if (GvCVGEN(topgv) == PL_sub_generation) + return 0; /* cache indicates sub doesn't exist */ + } + + gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); + av = (gvp && (gv = *gvp) && gv != (GV*)&PL_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*)&PL_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); } } - /* stale cached entry, just junk it */ - SvREFCNT_dec(cv); - GvCV(topgv) = cv = 0; - GvCVGEN(topgv) = 0; } - /* Now cv = 0, and there is no cv in topgv. */ - recurse: - 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; + /* NOTE: No support for tied ISA */ + I32 items = AvFILLp(av) + 1; while (items--) { SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { - if (dowarn) - warn("Can't locate package %s for @%s::ISA", + dTHR; /* just for ckWARN */ + if (ckWARN(WARN_MISC)) + warner(WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } - gv = gv_fetchmeth(basestash, name, len, level + (level >= 0 ? 1 : -1)); - if (gv && topgv) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ - SvREFCNT_inc(GvCV(gv)); - return gv; - } else if (gv) return gv; + gv = gv_fetchmeth(basestash, name, len, + (level >= 0) ? level + 1 : level - 1); + if (gv) + goto gotcha; } } - if ((level == 0) || (level == -1)) { /* topgv is present. */ + /* 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 + (level >= 0 ? 1 : -1))) { - GvCV(topgv) = GvCV(gv); /* cache the CV */ - GvCVGEN(topgv) = sub_generation; /* valid for now */ - SvREFCNT_inc(GvCV(gv)); + 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) = PL_sub_generation; + } return gv; } + else if (topgv && GvREFCNT(topgv) == 1) { + /* cache the fact that the method is not defined */ + GvCVGEN(topgv) = PL_sub_generation; + } } } @@ -203,127 +273,142 @@ 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(PL_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")) { - if (gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0)) { - /* One more chance... */ - SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0)); - sv_catpvn(tmpstr,"::", 2); - sv_catpvn(tmpstr, name, nend - name); - cv = GvCV(gv); - sv_setsv(GvSV(CvGV(cv)), tmpstr); - SvTAINTED_off(GvSV(CvGV(cv))); + 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; +} + +GV* +gv_autoload4(HV *stash, char *name, STRLEN len, I32 method) +{ + dTHR; + 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 (ckWARN(WARN_DEPRECATED) && !method && + (GvCVGEN(gv) || GvSTASH(gv) != stash)) + warner(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); + 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)) @@ -335,9 +420,7 @@ I32 create; } HV* -gv_stashsv(sv,create) -SV *sv; -I32 create; +gv_stashsv(SV *sv, I32 create) { register char *ptr; STRLEN len; @@ -347,19 +430,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++; @@ -369,29 +449,35 @@ I32 sv_type; (*namend == ':' && namend[1] == ':')) { if (!stash) - stash = defstash; + stash = PL_defstash; if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ return Nullgv; len = namend - name; if (len > 0) { - New(601, tmpbuf, len+3, char); + char smallbuf[256]; + char *tmpbuf; + + if (len + 3 < sizeof smallbuf) + tmpbuf = smallbuf; + 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*)&PL_sv_undef) { + if (SvTYPE(gv) != SVt_PVGV) + gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); + else + GvMULTI_on(gv); + } + if (tmpbuf != smallbuf) + Safefree(tmpbuf); + if (!gv || gv == (GV*)&PL_sv_undef) return Nullgv; - else - gv_init(gv, stash, nambeg, namend - nambeg, (add & 2)); if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); @@ -405,7 +491,7 @@ I32 sv_type; namend++; name = namend; if (!*name) - return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE); + return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); } } len = namend - name; @@ -415,36 +501,35 @@ I32 sv_type; /* No stash in name, so see how we can default */ if (!stash) { - if (isIDFIRST(*name)) { + if (isIDFIRST(*name) + || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name))) + { + bool global = FALSE; + if (isUPPER(*name)) { - if (*name > 'I') { - if (*name == 'S' && ( - strEQ(name, "SIG") || - strEQ(name, "STDIN") || - strEQ(name, "STDOUT") || - strEQ(name, "STDERR") )) - global = TRUE; - } - else if (*name > 'E') { - if (*name == 'I' && strEQ(name, "INC")) - global = TRUE; - } - else if (*name > 'A') { - if (*name == 'E' && strEQ(name, "ENV")) - global = TRUE; - } + if (*name == 'S' && ( + strEQ(name, "SIG") || + strEQ(name, "STDIN") || + strEQ(name, "STDOUT") || + strEQ(name, "STDERR"))) + global = TRUE; + else if (*name == 'I' && strEQ(name, "INC")) + global = TRUE; + else if (*name == 'E' && strEQ(name, "ENV")) + global = TRUE; else if (*name == 'A' && ( strEQ(name, "ARGV") || - strEQ(name, "ARGVOUT") )) + strEQ(name, "ARGVOUT"))) global = TRUE; } else if (*name == '_' && !name[1]) global = TRUE; + if (global) - stash = defstash; - else if ((COP*)curcop == &compiling) { - stash = curstash; - if (add && (hints & HINT_STRICT_VARS) && + stash = PL_defstash; + else if ((COP*)PL_curcop == &PL_compiling) { + stash = PL_curstash; + if (add && (PL_hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV && sv_type != SVt_PVGV && sv_type != SVt_PVFM && @@ -453,7 +538,7 @@ I32 sv_type; { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || - *gvp == (GV*)&sv_undef || + *gvp == (GV*)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { stash = 0; @@ -473,29 +558,42 @@ I32 sv_type; } } else - stash = curcop->cop_stash; + stash = PL_curcop->cop_stash; } else - stash = defstash; + stash = PL_defstash; } /* 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; + { + 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); + } + ++PL_error_count; + stash = PL_curstash ? PL_curstash : PL_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 */ return Nullgv; gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (GV*)&sv_undef) + if (!gvp || *gvp == (GV*)&PL_sv_undef) return Nullgv; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { @@ -504,14 +602,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) { @@ -535,7 +636,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)); @@ -556,7 +659,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 */ @@ -564,65 +667,89 @@ I32 sv_type; if (strEQ(name, "SIG")) { HV *hv; I32 i; - siggv = gv; - GvMULTI_on(siggv); - hv = GvHVn(siggv); - hv_magic(hv, siggv, 'S'); - for(i=1;sig_name[i];i++) { + PL_siggv = gv; + GvMULTI_on(PL_siggv); + hv = GvHVn(PL_siggv); + hv_magic(hv, PL_siggv, 'S'); + for(i=1;PL_sig_name[i];i++) { SV ** init; - init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1); + init=hv_fetch(hv,PL_sig_name[i],strlen(PL_sig_name[i]),1); if(init) - sv_setsv(*init,&sv_undef); - psig_ptr[i] = 0; - psig_name[i] = 0; + sv_setsv(*init,&PL_sv_undef); + PL_psig_ptr[i] = 0; + PL_psig_name[i] = 0; } - /* initialize signal stack */ - signalstack = newAV(); - AvREAL_off(signalstack); - av_extend(signalstack, 30); - av_fill(signalstack, 0); } break; case '&': if (len > 1) break; - ampergv = gv; - sawampersand = TRUE; + PL_ampergv = gv; + PL_sawampersand = TRUE; goto ro_magicalize; case '`': if (len > 1) break; - leftgv = gv; - sawampersand = TRUE; + PL_leftgv = gv; + PL_sawampersand = TRUE; goto ro_magicalize; case '\'': if (len > 1) break; - rightgv = gv; - sawampersand = TRUE; + PL_rightgv = gv; + PL_sawampersand = TRUE; goto ro_magicalize; case ':': if (len > 1) break; - sv_setpv(GvSV(gv),chopset); + sv_setpv(GvSV(gv),PL_chopset); goto magicalize; + case '?': + if (len > 1) + break; +#ifdef COMPLEX_STATUS + (void)SvUPGRADE(GvSV(gv), SVt_PVLV); +#endif + goto magicalize; + + case '!': + if (len > 1) + break; + if (sv_type > SVt_PV && PL_curcop != &PL_compiling) { + 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 available"); + } + } + goto magicalize; + case '-': + if (len > 1) + break; + else { + AV* av = GvAVn(gv); + sv_magic((SV*)av, Nullsv, 'D', Nullch, 0); + } + goto magicalize; case '#': case '*': - if (dowarn && len == 1 && sv_type == SVt_PV) - warn("Use of $%s is deprecated", name); + if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) + warner(WARN_DEPRECATED, "Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': - case '!': - case '?': case '^': case '~': case '=': - case '-': case '%': case '.': case '(': @@ -634,20 +761,33 @@ I32 sv_type; case '/': case '|': case '\001': + case '\002': + case '\003': case '\004': case '\005': case '\006': case '\010': + case '\011': /* NOT \t in EBCDIC */ case '\017': - case '\t': case '\020': case '\024': case '\027': if (len > 1) break; goto magicalize; + case '\023': + if (len > 1) + break; + goto ro_magicalize; case '+': + if (len > 1) + break; + else { + AV* av = GvAVn(gv); + sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0); + } + /* FALL THROUGH */ case '1': case '2': case '3': @@ -667,7 +807,7 @@ I32 sv_type; if (len > 1) break; sv_setpv(GvSV(gv),"\f"); - formfeed = GvSV(gv); + PL_formfeed = GvSV(gv); break; case ';': if (len > 1) @@ -676,10 +816,11 @@ I32 sv_type; break; case ']': if (len == 1) { - SV *sv; - sv = GvSV(gv); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, patchlevel); + SV *sv = GvSV(gv); + (void)SvUPGRADE(sv, SVt_PVNV); + sv_setpv(sv, PL_patchlevel); + (void)sv_2nv(sv); + SvREADONLY_on(sv); } break; } @@ -687,10 +828,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) { @@ -704,10 +842,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) @@ -717,25 +852,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; @@ -743,15 +875,18 @@ 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); + /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ + if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(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; @@ -765,19 +900,20 @@ HV* stash; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) { - if (hv != defstash) + if (hv != PL_defstash) gv_check(hv); /* nested package */ } 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); + PL_curcop->cop_line = GvLINE(gv); filegv = GvFILEGV(gv); - curcop->cop_filegv = filegv; + PL_curcop->cop_filegv = filegv; if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; - warn("Name \"%s::%s\" used only once: possible typo", + warner(WARN_ONCE, + "Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } @@ -785,27 +921,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)PL_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 */ + PL_sub_generation++; + } + } return gp; - } void -gp_free(gv) -GV* gv; +gp_free(GV *gv) { GP* gp; CV* cv; @@ -816,6 +960,10 @@ GV* gv; warn("Attempt to free unreferenced glob pointers"); return; } + if (gp->gp_cv) { + /* Deleting the name of a subroutine invalidates method cache */ + PL_sub_generation++; + } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; @@ -861,19 +1009,20 @@ 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; + STRLEN n_a; - if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation && - amtp->was_ok_sub == sub_generation) + if (mg && amtp->was_ok_am == PL_amagic_generation + && amtp->was_ok_sub == PL_sub_generation) return AMT_AMAGIC(amtp); if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */ int i; @@ -887,38 +1036,38 @@ 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.was_ok_am = PL_amagic_generation; + amt.was_ok_sub = PL_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)))) { + if (gvp && ((gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv)))) { int filled=0; int i; char *cp; SV* sv; SV** svp; - /* Work with "fallback" key, which we assume to be first in AMG_names */ + /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if (( cp = (char *)AMG_names[0] ) && + if (( cp = (char *)PL_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; i < NofAMmeth; i++) { cv = 0; - cp = (char *)AMG_names[i]; + cp = (char *)PL_AMG_names[i]; svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); - if (svp && ((sv = *svp) != &sv_undef)) { + if (svp && ((sv = *svp) != &PL_sv_undef)) { switch (SvTYPE(sv)) { default: if (!SvROK(sv)) { if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, na)); + gv = gv_fetchmethod(stash, SvPV(sv, n_a)); if (gv) cv = GvCV(gv); break; } @@ -949,45 +1098,41 @@ HV* stash; { int filled = 0; int i; - char *cp; + const char *cp; SV* sv = NULL; SV** svp; - /* Work with "fallback" key, which we assume to be first in AMG_names */ + /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if ( cp = (char *)AMG_names[0] ) { + if ( cp = PL_AMG_names[0] ) { /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, 0); /* A cooky: "()". */ + gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ if (gv) sv = GvSV(gv); - if (!sv) /* Empty */; + 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++) { - cv = 0; - cp = (char *)AMG_names[i]; - - *buf = '('; /* A cooky: "(". */ - strcpy(buf + 1, cp); + SV *cookie = sv_2mortal(newSVpvf("(%s", cp = PL_AMG_names[i])); DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); - gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling 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))) { - char *name = buf; 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(stash, SvPVX(GvSV(gv))))) { - name = SvPVX(GvSV(gv)); - cv = GvCV(gv = ngv); - } else { + SvPV(GvSV(gv), n_a), 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'", @@ -998,9 +1143,7 @@ HV* stash; (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), cp, HvNAME(stash)); } - /* If the sub is only a stub then we may have a gv to AUTOLOAD */ - gv = (GV*)*hv_fetch(GvSTASH(gv), name, strlen(name), TRUE); - cv = GvCV(gv); + cv = GvCV(gv = ngv); } DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), @@ -1017,33 +1160,28 @@ HV* stash; } } /* Here we have no table: */ + no_table: AMT_AMAGIC_off(&amt); sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); return FALSE; } -/* During call to this subroutine stack can be reallocated. It is - * advised to call SPAGAIN macro in your code after call */ - SV* -amagic_call(left,right,method,flags) -SV* left; -SV* right; -int method; -int flags; +amagic_call(SV *left, SV *right, int method, int flags) { + dTHR; MAGIC *mg; CV *cv; CV **cvp=NULL, **ocvp=NULL; AMT *amtp, *oamtp; int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; - int postpr=0, inc_dec_ass=0, assignshift=assign?1:0; + int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; HV* stash; if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table - : NULL)) + : (CV **) NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ @@ -1054,17 +1192,20 @@ int flags; int logic; /* look for substituted methods */ + /* In all the covered cases we should be called with assign==0. */ switch (method) { case inc_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; + force_cpy = 1; + if ((cv = cvp[off=add_ass_amg]) + || ((cv = cvp[off = add_amg]) && (force_cpy = 0, postpr = 1))) { + right = &PL_sv_yes; lr = -1; assign = 1; } break; case dec_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; + force_cpy = 1; + if ((cv = cvp[off = subtr_ass_amg]) + || ((cv = cvp[off = subtr_amg]) && (force_cpy = 0, postpr=1))) { + right = &PL_sv_yes; lr = -1; assign = 1; } break; case bool__amg: @@ -1084,17 +1225,19 @@ int flags; break; 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 */ - SV* newref = newSVsv(ref); + /* + * SV* ref causes confusion with the interpreter variable of + * the same name + */ + SV* tmpRef=SvRV(left); + if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { + /* + * Just to be extra cautious. Maybe in some + * additional cases sv_setsv is safe, too. + */ + SV* newref = newSVsv(tmpRef); SvOBJECT_on(newref); - SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref)); + SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef)); return newref; } } @@ -1130,6 +1273,15 @@ int flags; lr = 1; } break; + case iter_amg: /* XXXX Eventually should do to_gv. */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + break; default: goto not_found; } @@ -1138,7 +1290,7 @@ int flags; && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table - : NULL)) + : (CV **) NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1148,7 +1300,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 */ @@ -1181,9 +1333,12 @@ int flags; } 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", - 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", + PL_AMG_names[method + assignshift], + (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", @@ -1191,81 +1346,104 @@ 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 { - croak(buf); + croak("%_", msg); } return NULL; } + force_cpy = force_cpy || assign; } } if (!notfound) { - DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n", - AMG_names[off], + DEBUG_o( deb( + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + PL_AMG_names[off], method+assignshift==off? "" : " (initially `", method+assignshift==off? "" : - AMG_names[method+assignshift], + PL_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 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); - } + /* We need to copy in following cases: + * a) Assignment form was called. + * assignshift==1, assign==T, method + 1 == off + * b) Increment or decrement, called directly. + * assignshift==0, assign==0, method + 0 == off + * c) Increment or decrement, translated to assignment add/subtr. + * assignshift==0, assign==T, + * force_cpy == T + * d) Increment or decrement, translated to nomethod. + * assignshift==0, assign==0, + * force_cpy == T + * e) Assignment form translated to nomethod. + * assignshift==1, assign==T, method + 1 != off + * force_cpy == T + */ + /* off is method, method+assignshift, or a result of opcode substitution. + * In the latter case assignshift==0, so only notfound case is important. + */ + if (( (method + assignshift == off) + && (assign || (method == inc_amg) || (method == dec_amg))) + || force_cpy) + 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; + PUSHSTACKi(PERLSI_OVERLOAD); ENTER; - SAVESPTR(op); - op = (OP *) &myop; - if (perldb && curstash != debstash) - op->op_private |= OPpENTERSUB_DB; + SAVEOP(); + PL_op = (OP *) &myop; + if (PERLDB_SUB && PL_curstash != PL_debstash) + PL_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 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) ); + PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); } PUSHs((SV*)cv); PUTBACK; - if (op = pp_entersub()) - runops(); + if (PL_op = pp_entersub(ARGS)) + CALLRUNOPS(); LEAVE; SPAGAIN; res=POPs; PUTBACK; - - if (notfound) { - /* sv_2mortal(res); */ - return NULL; - } + POPSTACK; + CATCH_SET(oldcatch); if (postpr) { int ans; @@ -1294,7 +1472,7 @@ int flags; case not_amg: ans=!SvOK(res); break; } - return ans? &sv_yes: &sv_no; + return boolSV(ans); } else if (method==copy_amg) { if (!SvROK(res)) { croak("Copy method did not return a reference"); @@ -1306,3 +1484,4 @@ int flags; } } #endif /* OVERLOAD */ +