X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=a3e8d88392f91b422596969965a5bb0ee0faa4f8;hb=d0ecd44c5964f10ab34d28eea63e112aa8c61503;hp=01cad2e149bc20dda42cbc0b7e45c859059d45bc;hpb=462e5cf694f345fbf34a1f95e9a82957e59dcc2b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 01cad2e..a3e8d88 100644 --- a/gv.c +++ b/gv.c @@ -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,8 +50,7 @@ register GV *gv; } GV * -gv_fetchfile(name) -char *name; +gv_fetchfile(char *name) { dTHR; char smallbuf[256]; @@ -72,50 +66,76 @@ char *name; tmpbuf[0] = '_'; tmpbuf[1] = '<'; strcpy(tmpbuf + 2, name); - gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE); + 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)); + 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); 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; + 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: @@ -131,11 +151,7 @@ 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; @@ -146,7 +162,8 @@ I32 level; if (!stash) return 0; if ((level > 100) || (level < -100)) - croak("Recursive inheritance detected"); + 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)) ); @@ -159,20 +176,22 @@ I32 level; 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) + 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*)&sv_undef) ? GvAV(gv) : Nullav; + av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; - /* create @.*::SUPER::ISA on demand */ - if (!av) { + /* create and re-create @.*::SUPER::ISA on demand */ + if (!av || !SvMAGIC(av)) { char* packname = HvNAME(stash); STRLEN packlen = strlen(packname); @@ -182,7 +201,7 @@ I32 level; 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))) { + 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)) @@ -197,13 +216,15 @@ I32 level; 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; } @@ -233,14 +254,17 @@ I32 level; (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { - dTHR; /* just for SvREFCNT_inc */ if (cv = GvCV(topgv)) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); - GvCVGEN(topgv) = sub_generation; + 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; + } } } @@ -248,19 +272,15 @@ 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(stash, name, autoload) -HV* stash; -char* name; -I32 autoload; +gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload) { + dTHR; register char *nend; char *nsplit = 0; GV* gv; @@ -279,7 +299,7 @@ I32 autoload; 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))); + 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) ); @@ -291,7 +311,7 @@ I32 autoload; gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import")) - gv = (GV*)&sv_yes; + gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(stash, name, nend - name, TRUE); } @@ -319,12 +339,9 @@ I32 autoload; } GV* -gv_autoload4(stash, name, len, method) -HV* stash; -char* name; -STRLEN len; -I32 method; +gv_autoload4(HV *stash, char *name, STRLEN len, I32 method) { + dTHR; static char autoload[] = "AUTOLOAD"; static STRLEN autolen = 8; GV* gv; @@ -342,8 +359,9 @@ I32 method; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) - warn( + 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); @@ -366,18 +384,13 @@ I32 method; } 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 smallbuf[256]; char *tmpbuf; @@ -406,9 +419,7 @@ I32 create; } HV* -gv_stashsv(sv,create) -SV *sv; -I32 create; +gv_stashsv(SV *sv, I32 create) { register char *ptr; STRLEN len; @@ -418,10 +429,7 @@ 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; @@ -431,7 +439,6 @@ I32 sv_type; register char *namend; HV *stash = 0; U32 add_gvflags = 0; - char *tmpbuf; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -441,29 +448,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(); @@ -477,7 +490,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; @@ -487,39 +500,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 && @@ -528,7 +537,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; @@ -548,33 +557,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 */ - 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 + 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) { @@ -583,13 +601,15 @@ 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; @@ -615,7 +635,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)); @@ -636,7 +658,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 */ @@ -644,51 +666,46 @@ I32 sv_type; if (strEQ(name, "SIG")) { HV *hv; I32 i; - siggv = gv; - GvMULTI_on(siggv); - hv = GvHVn(siggv); - hv_magic(hv, siggv, 'S'); + PL_siggv = gv; + GvMULTI_on(PL_siggv); + hv = GvHVn(PL_siggv); + hv_magic(hv, PL_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); + sv_setsv(*init,&PL_sv_undef); 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; 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 '?': @@ -699,17 +716,39 @@ I32 sv_type; #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 '(': @@ -721,20 +760,32 @@ I32 sv_type; case '/': case '|': case '\001': + case '\002': 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': @@ -754,7 +805,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) @@ -765,7 +816,7 @@ I32 sv_type; if (len == 1) { SV *sv = GvSV(gv); sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, patchlevel); + sv_setpv(sv, PL_patchlevel); (void)sv_2nv(sv); SvREADONLY_on(sv); } @@ -775,10 +826,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) { @@ -792,10 +840,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) @@ -805,24 +850,20 @@ 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; @@ -832,14 +873,15 @@ 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; @@ -855,19 +897,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)); } } @@ -875,18 +918,16 @@ HV* stash; } GV * -newGVgen(pack) -char *pack; +newGVgen(char *pack) { - return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++), + 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) { @@ -898,15 +939,14 @@ GP* gp; } else { /* Adding a new name to a subroutine invalidates method cache */ - sub_generation++; + PL_sub_generation++; } } return gp; } void -gp_free(gv) -GV* gv; +gp_free(GV *gv) { GP* gp; CV* cv; @@ -919,7 +959,7 @@ GV* gv; } if (gp->gp_cv) { /* Deleting the name of a subroutine invalidates method cache */ - sub_generation++; + PL_sub_generation++; } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) @@ -966,8 +1006,7 @@ register GV *gv; /* Updates and caches the CV's */ bool -Gv_AMupdate(stash) -HV* stash; +Gv_AMupdate(HV *stash) { dTHR; GV** gvp; @@ -975,11 +1014,11 @@ HV* stash; 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->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; @@ -993,14 +1032,14 @@ 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; @@ -1019,12 +1058,12 @@ HV* stash; cp = (char *)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, PL_na)); if (gv) cv = GvCV(gv); break; } @@ -1085,7 +1124,7 @@ HV* stash; GV *ngv; DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV(GvSV(gv), na), cp, HvNAME(stash)) ); + SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) @@ -1123,15 +1162,8 @@ HV* stash; 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; @@ -1139,13 +1171,13 @@ 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, 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 */ @@ -1156,17 +1188,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: @@ -1186,15 +1221,19 @@ int flags; break; case copy_amg: { - SV* ref=SvRV(left); - if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { + /* + * 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(ref); + SV* newref = newSVsv(tmpRef); SvOBJECT_on(newref); - SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref)); + SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef)); return newref; } } @@ -1238,7 +1277,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; @@ -1308,6 +1347,7 @@ int flags; } return NULL; } + force_cpy = force_cpy || assign; } } if (!notfound) { @@ -1324,16 +1364,34 @@ int flags; 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); { - dTHR; dSP; BINOP myop; SV* res; @@ -1345,31 +1403,32 @@ int flags; myop.op_next = Nullop; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + PUSHSTACKi(PERLSI_OVERLOAD); ENTER; SAVEOP(); - op = (OP *) &myop; - if (perldb && curstash != debstash) - op->op_private |= OPpENTERSUB_DB; + PL_op = (OP *) &myop; + if (PERLDB_SUB && PL_curstash != PL_debstash) + PL_op->op_private |= OPpENTERSUB_DB; PUTBACK; pp_pushmark(ARGS); - EXTEND(sp, notfound + 5); + EXTEND(SP, notfound + 5); PUSHs(lr>0? right: left); PUSHs(lr>0? left: right); - PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &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*)cv); PUTBACK; - if (op = pp_entersub(ARGS)) - runops(); + if (PL_op = pp_entersub(ARGS)) + CALLRUNOPS(); LEAVE; SPAGAIN; res=POPs; - PUTBACK; + POPSTACK; CATCH_SET(oldcatch); if (postpr) { @@ -1411,3 +1470,4 @@ int flags; } } #endif /* OVERLOAD */ +