X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d7aacf4ee7905e48b1ff143784e4166839441b3c..938c8732ceb115a707f725327a631eb35319ba87:/gv.c?ds=sidebyside diff --git a/gv.c b/gv.c index 7d21f02..d1ba5a3 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,7 @@ /* gv.c * - * Copyright (c) 1991-2003, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -193,6 +194,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) return 0; } + if (!HvNAME(stash)) + Perl_croak(aTHX_ + "Can't use anonymous symbol table for method lookup"); + if ((level > 100) || (level < -100)) Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); @@ -687,8 +692,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) } } len = namend - name; - if (!len) - len = 1; + + /* $_ should always be in main:: even when our'ed */ + if (*name == '_' && !name[1]) + stash = PL_defstash; /* No stash in name, so see how we can default */ @@ -717,7 +724,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (global) stash = PL_defstash; - else if ((COP*)PL_curcop == &PL_compiling) { + else if (IN_PERL_COMPILETIME) { stash = PL_curstash; if (add && (PL_hints & HINT_STRICT_VARS) && sv_type != SVt_PVCV && @@ -758,12 +765,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (!stash) { if (add) { - qerror(Perl_mess(aTHX_ + register SV *err = Perl_mess(aTHX_ "Global symbol \"%s%s\" requires explicit package name", (sv_type == SVt_PV ? "$" : sv_type == SVt_PVAV ? "@" : sv_type == SVt_PVHV ? "%" - : ""), name)); + : ""), name); + if (USE_UTF8_IN_NAMES) + SvUTF8_on(err); + qerror(err); stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); } else @@ -922,10 +932,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) SvREADONLY_on(av); } goto magicalize; - case '#': case '*': - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name); + if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "$* is no longer supported"); + break; + case '#': + if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Use of $# is deprecated"); /* FALL THROUGH */ case '[': case '^': @@ -1065,14 +1080,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) void Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) { + char *name; HV *hv = GvSTASH(gv); if (!hv) { (void)SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); - if (keepmain || strNE(HvNAME(hv), "main")) { - sv_catpv(sv,HvNAME(hv)); + + if (!HvNAME(hv)) + name = "__ANON__"; + else + name = HvNAME(hv); + if (keepmain || strNE(name, "main")) { + sv_catpv(sv,name); sv_catpvn(sv,"::", 2); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); @@ -1147,7 +1168,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))) + (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ @@ -1225,7 +1246,8 @@ Perl_gp_free(pTHX_ GV *gv) if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced glob pointers"); + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_cv) { @@ -1238,12 +1260,18 @@ Perl_gp_free(pTHX_ GV *gv) return; } - SvREFCNT_dec(gp->gp_sv); - SvREFCNT_dec(gp->gp_av); - SvREFCNT_dec(gp->gp_hv); - SvREFCNT_dec(gp->gp_io); - SvREFCNT_dec(gp->gp_cv); - SvREFCNT_dec(gp->gp_form); + if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv); + if (gp->gp_av) SvREFCNT_dec(gp->gp_av); + if (gp->gp_hv) { + if (PL_stashcache && HvNAME(gp->gp_hv)) + hv_delete(PL_stashcache, + HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)), + G_DISCARD); + SvREFCNT_dec(gp->gp_hv); + } + if (gp->gp_io) SvREFCNT_dec(gp->gp_io); + if (gp->gp_cv) SvREFCNT_dec(gp->gp_cv); + if (gp->gp_form) SvREFCNT_dec(gp->gp_form); Safefree(gp); GvGP(gv) = 0; @@ -1339,7 +1367,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* GvSV contains the name of the method. */ GV *ngv = Nullgv; - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n", + DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\ + "' for overloaded `%s' in package `%.256s'\n", GvSV(gv), cp, HvNAME(stash)) ); if (!SvPOK(GvSV(gv)) || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)), @@ -1348,7 +1377,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* Can be an import stub (created by `can'). */ SV *gvsv = GvSV(gv); const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???"; - Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'", + Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\ + "in package `%.256s'", (GvCVGEN(gv) ? "Stub found while resolving" : "Can't resolve"), name, cp, HvNAME(stash)); @@ -1392,7 +1422,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) AMT *amtp; CV *ret; - if (!stash) + if (!stash || !HvNAME(stash)) return Nullcv; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { @@ -1824,7 +1854,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '!': case '-': case '#': - case '*': case '[': case '^': case '~':