X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=5ab21b13839f0febf63b3a19948936c518fdaa0b;hb=be26652545762cccb4c0118f022cf9d0ec20cf93;hp=5a91c08fab09c032b972be3f4189fc65b53f7813;hpb=16070b82c8557c1a47b3ee4bee2b551efb7b3eb7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 5a91c08..5ab21b1 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, 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. @@ -168,7 +168,7 @@ up caching info for this glob. Similarly for all the searched stashes. This function grants C<"SUPER"> token as a postfix of the stash name. The GV returned from C may be a method cache entry, which is not -visible to Perl code. So when calling C, you should not use +visible to Perl code. So when calling C, you should not use the GV directly; instead, you should use the method's CV, which can be obtained from the GV with the C macro. @@ -199,7 +199,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) topgv = *gvp; if (SvTYPE(topgv) != SVt_PVGV) gv_init(topgv, stash, name, len, TRUE); - if (cv = GvCV(topgv)) { + if ((cv = GvCV(topgv))) { /* If genuine method or valid cache entry, use it */ if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) return topgv; @@ -265,9 +265,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) if (level == 0 || level == -1) { HV* lastchance; - if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) { - if (gv = gv_fetchmeth(lastchance, name, len, - (level >= 0) ? level + 1 : level - 1)) { + if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) { + if ((gv = gv_fetchmeth(lastchance, name, len, + (level >= 0) ? level + 1 : level - 1))) + { gotcha: /* * Cache method in topgv if: @@ -279,7 +280,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { - if (cv = GvCV(topgv)) + if ((cv = GvCV(topgv))) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); GvCVGEN(topgv) = PL_sub_generation; @@ -299,7 +300,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) /* =for apidoc gv_fetchmethod -See L. =cut */ @@ -333,7 +334,7 @@ created via a side effect to do this. These functions have the same side-effects and as C with C. C should be writable if contains C<':'> or C<' ''>. The warning against passing the GV returned by C to -C apply equally to these functions. +C apply equally to these functions. =cut */ @@ -447,10 +448,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* =for apidoc gv_stashpv -Returns a pointer to the stash for a specified package. If C is -set then the package will be created if it does not already exist. If -C is not set and the package does not exist then NULL is -returned. +Returns a pointer to the stash for a specified package. C should +be a valid UTF-8 string. If C is set then the package will be +created if it does not already exist. If C is not set and the +package does not exist then NULL is returned. =cut */ @@ -493,8 +494,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) /* =for apidoc gv_stashsv -Returns a pointer to the stash for a specified package. See -C. +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C. =cut */ @@ -519,7 +520,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) I32 len; register const char *namend; HV *stash = 0; - U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; @@ -581,9 +581,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) /* No stash in name, so see how we can default */ if (!stash) { - if (isIDFIRST(*name) - || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name))) - { + if (isIDFIRST_lazy(name)) { bool global = FALSE; if (isUPPER(*name)) { @@ -623,16 +621,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { stash = 0; } - else if (sv_type == SVt_PV && !GvIMPORTED_SV(*gvp) || - sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) || - sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) ) + else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || + (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || + (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); if (GvCVu(*gvp)) - Perl_warn(aTHX_ "(Did you mean &%s instead?)\n", name); + Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); stash = 0; } } @@ -654,8 +652,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" : ""), name)); + stash = PL_nullstash; } - return Nullgv; + else + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -681,7 +681,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); - GvFLAGS(gv) |= add_gvflags; if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) GvMULTI_on(gv) ; @@ -846,8 +845,9 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len > 1) break; goto ro_magicalize; - case '\027': /* $^W & $^Warnings */ - if (len > 1 && strNE(name, "\027arnings")) + case '\027': /* $^W & $^WARNING_BITS */ + if (len > 1 && strNE(name, "\027ARNING_BITS") + && strNE(name, "\027IDE_SYSTEM_CALLS")) break; goto magicalize; @@ -911,7 +911,7 @@ Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { HV *hv = GvSTASH(gv); if (!hv) { - SvOK_off(sv); + (void)SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); @@ -1044,7 +1044,6 @@ Perl_gp_free(pTHX_ GV *gv) { dTHR; GP* gp; - CV* cv; if (!gv || !(gp = GvGP(gv))) return; @@ -1104,15 +1103,17 @@ register GV *gv; bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; - GV** gvp; - HV* hv; + dTHR; GV* gv; CV* cv; MAGIC* mg=mg_find((SV*)stash,'c'); 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) @@ -1193,18 +1194,21 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) int i; const char *cp; SV* sv = NULL; - SV** svp; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ - if ( cp = PL_AMG_names[0] ) { + 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; + if (gv) + sv = GvSV(gv); + + if (!gv) + goto no_table; + else if (SvTRUE(sv)) + amt.fallback=AMGfallYES; + else if (SvOK(sv)) + amt.fallback=AMGfallNEVER; } for (i = 1; i < NofAMmeth; i++) { @@ -1360,7 +1364,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } break; case neg_amg: - if (cv = cvp[off=subtr_amg]) { + if ((cv = cvp[off=subtr_amg])) { right = left; left = sv_2mortal(newSViv(0)); lr = 1; @@ -1528,7 +1532,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs((SV*)cv); PUTBACK; - if (PL_op = Perl_pp_entersub(aTHX)) + if ((PL_op = Perl_pp_entersub(aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN;