X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/22d4bb9ccb8701e68f9243547d7e3a3c55f70908..2826e23d06eb57e0799af5f9f67c55c5975ba0e5:/gv.c diff --git a/gv.c b/gv.c index 768824d..33e6cd2 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-2000, Larry Wall + * Copyright (c) 1991-2001, 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. @@ -45,15 +45,20 @@ Perl_gv_IOadd(pTHX_ register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for filehandle"); - if (!GvIOp(gv)) + if (!GvIOp(gv)) { +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)"); + } +#endif GvIOp(gv) = newIO(); + } return gv; } GV * Perl_gv_fetchfile(pTHX_ const char *name) { - dTHR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; @@ -75,7 +80,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); sv_setpv(GvSV(gv), name); if (PERLDB_LINE) - hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, 'L'); + hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) Safefree(tmpbuf); @@ -85,7 +90,6 @@ Perl_gv_fetchfile(pTHX_ const char *name) void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { - dTHR; register GP *gp; bool doproto = SvTYPE(gv) > SVt_NULL; char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; @@ -106,7 +110,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', Nullch, 0); + sv_magic((SV*)gv, (SV*)gv, PERL_MAGIC_glob, Nullch, 0); GvSTASH(gv) = (HV*)SvREFCNT_inc(stash); GvNAME(gv) = savepvn(name, len); GvNAMELEN(gv) = len; @@ -121,16 +125,16 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) LEAVE; PL_sub_generation++; - CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); - CvFILE(GvCV(gv)) = CopFILE(PL_curcop); + CvGV(GvCV(gv)) = gv; + CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; -#ifdef USE_THREADS +#ifdef USE_5005THREADS CvOWNER(GvCV(gv)) = 0; if (!CvMUTEXP(GvCV(gv))) { New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(GvCV(gv))); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); @@ -159,7 +163,7 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) Returns the glob with the given C and a defined subroutine or C. The glob lives in the given C, or in the stashes -accessible via @ISA and @UNIVERSAL. +accessible via @ISA and UNIVERSAL::. The argument C should be either 0 or -1. If C, as a side-effect creates a glob with the given C in the given C @@ -184,8 +188,13 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) GV** gvp; CV* cv; - if (!stash) - return 0; + /* UNIVERSAL methods should be callable without a stash */ + if (!stash) { + level = -1; /* probably appropriate */ + if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) + return 0; + } + if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); @@ -227,7 +236,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) 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)) Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); @@ -247,7 +255,6 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { - dTHR; /* just for ckWARN */ if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); @@ -342,7 +349,6 @@ C apply equally to these functions. GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { - dTHR; register const char *nend; const char *nsplit = 0; GV* gv; @@ -362,12 +368,14 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); + /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else - stash = gv_stashpvn(origname, nsplit - origname, TRUE); + /* don't autovifify if ->NoSuchStash::method */ + stash = gv_stashpvn(origname, nsplit - origname, FALSE); } gv = gv_fetchmeth(stash, name, nend - name, 0); @@ -403,7 +411,6 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - dTHR; static char autoload[] = "AUTOLOAD"; static STRLEN autolen = 8; GV* gv; @@ -412,13 +419,15 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) GV* vargv; SV* varsv; + if (!stash) + return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); - if (!CvROOT(cv)) + if (!(CvROOT(cv) || CvXSUB(cv))) return Nullgv; /* @@ -430,6 +439,20 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); +#ifndef USE_5005THREADS + if (CvXSUB(cv)) { + /* rather than lookup/init $AUTOLOAD here + * only to have the XSUB do another lookup for $AUTOLOAD + * and split that value on the last '::', + * pass along the same data via some unused fields in the CV + */ + CvSTASH(cv) = stash; + SvPVX(cv) = (char *)name; /* cast to lose constness warning */ + SvCUR(cv) = len; + return gv; + } +#endif + /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. * The subroutine's original name may not be "AUTOLOAD", so we don't @@ -440,14 +463,14 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; -#ifdef USE_THREADS +#ifdef USE_5005THREADS sv_lock((SV *)varstash); #endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); -#ifdef USE_THREADS +#ifdef USE_5005THREADS sv_lock(varsv); #endif sv_setpv(varsv, HvNAME(stash)); @@ -457,6 +480,28 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) return gv; } +/* The "gv" parameter should be the glob known to Perl code as *! + * The scalar must already have been magicalized. + */ +STATIC void +S_require_errno(pTHX_ GV *gv) +{ + HV* stash = gv_stashpvn("Errno",5,FALSE); + + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + dSP; + PUTBACK; + ENTER; + save_scalar(gv); /* keep the value of $! */ + require_pv("Errno.pm"); + LEAVE; + SPAGAIN; + stash = gv_stashpvn("Errno",5,FALSE); + if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) + Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); + } +} + /* =for apidoc gv_stashpv @@ -525,7 +570,6 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create) GV * Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - dTHR; register const char *name = nambeg; register GV *gv = 0; GV**gvp; @@ -681,6 +725,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); + if (*name=='!' && sv_type == SVt_PVHV && len==1) + require_errno(gv); } return gv; } else if (add & GV_NOINIT) { @@ -694,7 +740,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; /* set up magic where warranted */ @@ -712,7 +759,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (strEQ(name, "ISA")) { AV* av = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0); + sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0); /* NOTE: No support for tied ISA */ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) @@ -735,7 +782,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); GvMULTI_on(gv); - hv_magic(hv, Nullgv, 'A'); + hv_magic(hv, Nullgv, PERL_MAGIC_overload); } break; case 'S': @@ -743,20 +790,21 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) HV *hv; I32 i; if (!PL_psig_ptr) { - int sig_num[] = { SIG_NUM }; - New(73, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); - New(73, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + Newz(73, PL_psig_ptr, SIG_SIZE, SV*); + Newz(73, PL_psig_name, SIG_SIZE, SV*); + Newz(73, PL_psig_pend, SIG_SIZE, int); } GvMULTI_on(gv); hv = GvHVn(gv); - hv_magic(hv, Nullgv, 'S'); - for (i = 1; PL_sig_name[i]; i++) { + hv_magic(hv, Nullgv, PERL_MAGIC_sig); + for (i = 1; i < SIG_SIZE; i++) { SV ** init; init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1); if (init) sv_setsv(*init, &PL_sv_undef); PL_psig_ptr[i] = 0; PL_psig_name[i] = 0; + PL_psig_pend[i] = 0; } } break; @@ -800,25 +848,25 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) 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; - require_pv("Errno.pm"); - SPAGAIN; - stash = gv_stashpvn("Errno",5,FALSE); - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) - Perl_croak(aTHX_ "Can't use %%! because Errno.pm is not available"); - } - } - goto magicalize; + + /* If %! has been used, automatically load Errno.pm. + The require will itself set errno, so in order to + preserve its value we have to set up the magic + now (rather than going to magicalize) + */ + + sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + + if (sv_type == SVt_PVHV) + require_errno(gv); + + break; case '-': if (len > 1) break; else { AV* av = GvAVn(gv); - sv_magic((SV*)av, Nullsv, 'D', Nullch, 0); + sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); SvREADONLY_on(av); } goto magicalize; @@ -840,7 +888,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case ',': case '\\': case '/': - case '|': case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ @@ -848,12 +895,21 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ - case '\017': /* $^O */ + case '\016': /* $^N */ case '\020': /* $^P */ case '\024': /* $^T */ if (len > 1) break; goto magicalize; + case '|': + if (len > 1) + break; + sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); + goto magicalize; + case '\017': /* $^O & $^OPEN */ + if (len > 1 && strNE(name, "\017PEN")) + break; + goto magicalize; case '\023': /* $^S */ if (len > 1) break; @@ -869,7 +925,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) break; else { AV* av = GvAVn(gv); - sv_magic((SV*)av, (SV*)av, 'D', Nullch, 0); + sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); SvREADONLY_on(av); } /* FALL THROUGH */ @@ -882,10 +938,21 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '7': case '8': case '9': + /* ensures variable is only digits */ + /* ${"1foo"} fails this test (and is thus writeable) */ + /* added by japhy, but borrowed from is_gv_magical */ + + if (len > 1) { + const char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) return gv; + } + } + ro_magicalize: SvREADONLY_on(GvSV(gv)); magicalize: - sv_magic(GvSV(gv), (SV*)gv, 0, name, len); + sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len); break; case '\014': /* $^L */ @@ -992,7 +1059,6 @@ Perl_gv_efullname(pTHX_ SV *sv, GV *gv) IO * Perl_newIO(pTHX) { - dTHR; IO *io; GV *iogv; @@ -1011,7 +1077,6 @@ Perl_newIO(pTHX) void Perl_gv_check(pTHX_ HV *stash) { - dTHR; register HE *entry; register I32 i; register GV *gv; @@ -1022,7 +1087,7 @@ Perl_gv_check(pTHX_ HV *stash) for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && - (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv)) + (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ @@ -1037,7 +1102,12 @@ Perl_gv_check(pTHX_ HV *stash) * module, don't bother warning */ if (file && PERL_FILE_IS_ABSOLUTE(file) - && (instr(file, "/lib/") || instr(file, ".pm"))) +#ifdef MACOS_TRADITIONAL + && (instr(file, ":lib:") +#else + && (instr(file, "/lib/") +#endif + || instr(file, ".pm"))) { continue; } @@ -1088,7 +1158,6 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { - dTHR; GP* gp; if (!gv || !(gp = GvGP(gv))) @@ -1144,134 +1213,87 @@ register GV *gv; } #endif /* Microport 2.4 hack */ +int +Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) +{ + AMT *amtp = (AMT*)mg->mg_ptr; + if (amtp && AMT_AMAGIC(amtp)) { + int i; + for (i = 1; i < NofAMmeth; i++) { + CV *cv = amtp->table[i]; + if (cv != Nullcv) { + SvREFCNT_dec((SV *) cv); + amtp->table[i] = Nullcv; + } + } + } + return 0; +} + /* Updates and caches the CV's */ bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; GV* gv; CV* cv; - MAGIC* mg=mg_find((SV*)stash,'c'); + MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table); AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; AMT amt; - STRLEN n_a; -#ifdef OVERLOAD_VIA_HASH - GV** gvp; - HV* hv; -#endif 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; - for (i=1; itable[i]) { - SvREFCNT_dec(amtp->table[i]); - } - } - } - sv_unmagic((SV*)stash, 'c'); + return AMT_OVERLOADED(amtp); + sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + Zero(&amt,1,AMT); 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*)&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 PL_AMG_names */ - - 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 *)PL_AMG_names[i]; - - svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE); - if (svp && ((sv = *svp) != &PL_sv_undef)) { - switch (SvTYPE(sv)) { - default: - if (!SvROK(sv)) { - if (!SvOK(sv)) break; - gv = gv_fetchmethod(stash, SvPV(sv, n_a)); - if (gv) cv = GvCV(gv); - break; - } - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: - Perl_croak(aTHX_ "Not a subroutine reference in overload table"); - return FALSE; - case SVt_PVCV: - cv = (CV*)sv; - break; - case SVt_PVGV: - if (!(cv = GvCVu((GV*)sv))) - cv = sv_2cv(sv, &stash, &gv, FALSE); - break; - } - if (cv) filled=1; - else { - Perl_croak(aTHX_ "Method for operation %s not found in package %.256s during blessing\n", - cp,HvNAME(stash)); - return FALSE; - } - } -#else { - int filled = 0; - int i; - const char *cp; + int filled = 0, have_ovl = 0; + int i, lim = 1; SV* sv = NULL; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if ((cp = PL_AMG_names[0])) { - /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */ - if (gv) - sv = GvSV(gv); - - if (!gv) - goto no_table; - else if (SvTRUE(sv)) - amt.fallback=AMGfallYES; - else if (SvOK(sv)) - amt.fallback=AMGfallNEVER; - } + /* Try to find via inheritance. */ + gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + if (gv) + sv = GvSV(gv); + + if (!gv) + lim = DESTROY_amg; /* Skip overloading entries. */ + else if (SvTRUE(sv)) + amt.fallback=AMGfallYES; + else if (SvOK(sv)) + amt.fallback=AMGfallNEVER; + + for (i = 1; i < lim; i++) + amt.table[i] = Nullcv; + for (; i < NofAMmeth; i++) { + char *cooky = (char*)PL_AMG_names[i]; + /* Human-readable form, for debugging: */ + char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); + STRLEN l = strlen(cooky); - for (i = 1; i < NofAMmeth; i++) { - SV *cookie = sv_2mortal(Perl_newSVpvf(aTHX_ "(%s", cp = PL_AMG_names[i])); DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", cp, HvNAME(stash)) ); /* don't fill the cache while looking up! */ - gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1); + gv = gv_fetchmeth(stash, cooky, l, -1); cv = 0; - if(gv && (cv = GvCV(gv))) { + if (gv && (cv = GvCV(gv))) { if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { /* GvSV contains the name of the method. */ GV *ngv; DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV(GvSV(gv), n_a), cp, HvNAME(stash)) ); + SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), FALSE))) @@ -1292,43 +1314,80 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; } -#endif amt.table[i]=(CV*)SvREFCNT_inc(cv); } if (filled) { AMT_AMAGIC_on(&amt); - sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT)); - return TRUE; + if (have_ovl) + AMT_OVERLOADED_on(&amt); + sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + (char*)&amt, sizeof(AMT)); + return have_ovl; } } /* Here we have no table: */ - no_table: + /* no_table: */ AMT_AMAGIC_off(&amt); - sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS)); + sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + (char*)&amt, sizeof(AMTS)); return FALSE; } + +CV* +Perl_gv_handler(pTHX_ HV *stash, I32 id) +{ + MAGIC *mg; + AMT *amtp; + + if (!stash) + return Nullcv; + mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + if (!mg) { + do_update: + Gv_AMupdate(stash); + mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + } + amtp = (AMT*)mg->mg_ptr; + if ( amtp->was_ok_am != PL_amagic_generation + || amtp->was_ok_sub != PL_sub_generation ) + goto do_update; + if (AMT_AMAGIC(amtp)) + return amtp->table[id]; + return Nullcv; +} + + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dTHR; MAGIC *mg; - CV *cv; + CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; - AMT *amtp, *oamtp; - int fl=0, off, off1, lr=0, assign=AMGf_assign & flags, notfound=0; + AMT *amtp=NULL, *oamtp=NULL; + int off=0, off1, lr=0, assign=AMGf_assign & flags, notfound=0; int postpr = 0, force_cpy = 0, assignshift = assign ? 1 : 0; - HV* stash; +#ifdef DEBUGGING + int fl=0; +#endif + HV* stash=NULL; if (!(AMGf_noleft & flags) && SvAMAGIC(left) - && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c')) + && (stash = SvSTASH(SvRV(left))) + && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_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 */ - (fl = 1, cv = cvp[off=method])))) { + ( +#ifdef DEBUGGING + fl = 1, +#endif + cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { @@ -1416,6 +1475,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) lr = 1; } break; + case int_amg: case iter_amg: /* XXXX Eventually should do to_gv. */ /* FAIL safe */ return NULL; /* Delegate operation to standard mechanisms. */ @@ -1433,7 +1493,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) + && (stash = SvSTASH(SvRV(right))) + && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table : (CV **) NULL)) @@ -1493,7 +1554,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ "Operation `%s': no method found,%sargument %s%s%s%s", - PL_AMG_names[method + assignshift], + AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": @@ -1519,21 +1580,23 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) force_cpy = force_cpy || assign; } } +#ifdef DEBUGGING if (!notfound) { - DEBUG_o( Perl_deb(aTHX_ - "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? "" : - 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": "") ); + DEBUG_o(Perl_deb(aTHX_ + "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + AMG_id2name(off), + method+assignshift==off? "" : + " (initially `", + method+assignshift==off? "" : + AMG_id2name(method+assignshift), + method+assignshift==off? "" : "')", + flags & AMGf_unary? "" : + lr==1 ? " for right argument": " for left argument", + flags & AMGf_unary? " for argument" : "", + stash ? HvNAME(stash) : "null", + fl? ",\n\tassignment variant used": "") ); } +#endif /* Since we use shallow copy during assignment, we need * to dublicate the contents, probably calling user-supplied * version of copy operator @@ -1586,7 +1649,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv((char *)PL_AMG_names[method + assignshift],0))); + PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); } PUSHs((SV*)cv); PUTBACK; @@ -1602,7 +1665,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CATCH_SET(oldcatch); if (postpr) { - int ans; + int ans=0; switch (method) { case le_amg: case sle_amg: @@ -1672,6 +1735,13 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) if (len == 3 && strEQ(name, "SIG")) goto yes; break; + case '\017': /* $^O & $^OPEN */ + if (len == 1 + || (len == 4 && strEQ(name, "\027PEN"))) + { + goto yes; + } + break; case '\027': /* $^W & $^WARNING_BITS */ if (len == 1 || (len == 12 && strEQ(name, "\027ARNING_BITS")) @@ -1715,7 +1785,7 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\014': /* $^L */ - case '\017': /* $^O */ + case '\016': /* $^N */ case '\020': /* $^P */ case '\023': /* $^S */ case '\024': /* $^T */