X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2b5276ceb02fdf27e0fee45e5cba9ffcdae61d6b..59b0a8b7fe6b66a1488f6943ad58e73704f876b0:/gv.c diff --git a/gv.c b/gv.c index 6538377..68328ac 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,7 @@ /* gv.c * - * Copyright (c) 1991-2001, 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. @@ -16,6 +17,10 @@ * laughed Pippin. */ +/* +=head1 GV Functions +*/ + #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" @@ -72,6 +77,7 @@ Perl_gv_fetchfile(pTHX_ const char *name) tmpbuf = smallbuf; else New(603, tmpbuf, tmplen + 1, char); + /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; strcpy(tmpbuf + 2, name); @@ -128,13 +134,6 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) CvGV(GvCV(gv)) = gv; CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; -#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_5005THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); @@ -195,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)); @@ -256,8 +259,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA", - SvPVX(sv), HvNAME(stash)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", + sv, HvNAME(stash)); continue; } gv = gv_fetchmeth(basestash, name, len, @@ -305,6 +308,50 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) } /* +=for apidoc gv_fetchmeth_autoload + +Same as gv_fetchmeth(), but looks for autoloaded subroutines too. +Returns a glob for the subroutine. + +For an autoloaded subroutine without a GV, will create a GV even +if C. For an autoloaded subroutine without a stub, GvCV() +of the result may be zero. + +=cut +*/ + +GV * +Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) +{ + GV *gv = gv_fetchmeth(stash, name, len, level); + + if (!gv) { + char autoload[] = "AUTOLOAD"; + STRLEN autolen = sizeof(autoload)-1; + CV *cv; + GV **gvp; + + 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) || CvXSUB(cv))) + return Nullgv; + /* Have an autoload */ + if (level < 0) /* Cannot do without a stub */ + gv_fetchmeth(stash, name, len, 0); + gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); + if (!gvp) + return Nullgv; + return *gvp; + } + return gv; +} + +/* =for apidoc gv_fetchmethod See L. @@ -352,6 +399,10 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) register const char *nend; const char *nsplit = 0; GV* gv; + HV* ostash = stash; + + if (stash && SvTYPE(stash) < SVt_PVHV) + stash = Nullhv; for (nend = name; *nend; nend++) { if (*nend == '\'') @@ -373,9 +424,18 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } - else + else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, FALSE); + + /* however, explicit calls to Pkg::SUPER::method may + happen, and may require autovivification to work */ + if (!stash && (nsplit - origname) >= 7 && + strnEQ(nsplit - 7, "::SUPER", 7) && + gv_stashpvn(origname, nsplit - origname - 7, FALSE)) + stash = gv_stashpvn(origname, nsplit - origname, TRUE); + } + ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); @@ -383,7 +443,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) - gv = gv_autoload4(stash, name, nend - name, TRUE); + gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); @@ -411,18 +471,26 @@ 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) { - static char autoload[] = "AUTOLOAD"; - static STRLEN autolen = 8; + char autoload[] = "AUTOLOAD"; + STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; + char *packname = ""; - if (!stash) - return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; + if (stash) { + if (SvTYPE(stash) < SVt_PVHV) { + packname = SvPV_nolen((SV*)stash); + stash = Nullhv; + } + else { + packname = HvNAME(stash); + } + } if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) return Nullgv; cv = GvCV(gv); @@ -433,13 +501,12 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (ckWARN(WARN_DEPRECATED) && !method && + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", - HvNAME(stash), (int)len, name); + packname, (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 @@ -451,7 +518,6 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) SvCUR(cv) = len; return gv; } -#endif /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. @@ -463,17 +529,11 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); ENTER; -#ifdef USE_5005THREADS - sv_lock((SV *)varstash); -#endif if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); LEAVE; varsv = GvSV(vargv); -#ifdef USE_5005THREADS - sv_lock(varsv); -#endif - sv_setpv(varsv, HvNAME(stash)); + sv_setpv(varsv, packname); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); @@ -493,7 +553,8 @@ S_require_errno(pTHX_ GV *gv) PUTBACK; ENTER; save_scalar(gv); /* keep the value of $! */ - require_pv("Errno.pm"); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn("Errno",5), Nullsv); LEAVE; SPAGAIN; stash = gv_stashpvn("Errno",5,FALSE); @@ -594,7 +655,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) char smallbuf[256]; char *tmpbuf; - if (len + 3 < sizeof smallbuf) + if (len + 3 < sizeof (smallbuf)) tmpbuf = smallbuf; else New(601, tmpbuf, len+3, char); @@ -631,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 */ @@ -661,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 && @@ -702,13 +765,16 @@ 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)); - stash = PL_nullstash; + : ""), name); + if (USE_UTF8_IN_NAMES) + SvUTF8_on(err); + qerror(err); + stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); } else return Nullgv; @@ -736,7 +802,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) /* Adding a new symbol */ if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); @@ -866,10 +932,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) SvREADONLY_on(av); } goto magicalize; - case '#': case '*': - if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) - Perl_warner(aTHX_ WARN_DEPRECATED, "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 '^': @@ -887,13 +958,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\001': /* $^A */ case '\003': /* $^C */ case '\004': /* $^D */ - case '\005': /* $^E */ case '\006': /* $^F */ case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\016': /* $^N */ case '\020': /* $^P */ - case '\024': /* $^T */ if (len > 1) break; goto magicalize; @@ -902,6 +971,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) break; sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; + case '\005': /* $^E && $^ENCODING */ + if (len > 1 && strNE(name, "\005NCODING")) + break; + goto magicalize; + case '\017': /* $^O & $^OPEN */ if (len > 1 && strNE(name, "\017PEN")) break; @@ -910,9 +984,22 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len > 1) break; goto ro_magicalize; + case '\024': /* $^T, ${^TAINT} */ + if (len == 1) + goto magicalize; + else if (strEQ(name, "\024AINT")) + goto ro_magicalize; + else + break; + case '\025': + if (len > 1 && strNE(name, "\025NICODE")) + break; + goto ro_magicalize; + case '\027': /* $^W & $^WARNING_BITS */ - if (len > 1 && strNE(name, "\027ARNING_BITS") - && strNE(name, "\027IDE_SYSTEM_CALLS")) + if (len > 1 + && strNE(name, "\027ARNING_BITS") + ) break; goto magicalize; @@ -993,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)); @@ -1009,15 +1102,7 @@ Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) void Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { - HV *hv = GvSTASH(gv); - if (!hv) { - (void)SvOK_off(sv); - return; - } - sv_setpv(sv, prefix ? prefix : ""); - sv_catpv(sv,HvNAME(hv)); - sv_catpvn(sv,"::", 2); - sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); + gv_fullname4(sv, gv, prefix, TRUE); } void @@ -1032,10 +1117,7 @@ Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) void Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) { - GV *egv = GvEGV(gv); - if (!egv) - egv = gv; - gv_fullname3(sv, egv, prefix); + gv_efullname4(sv, gv, prefix, TRUE); } /* XXX compatibility with versions <= 5.003. */ @@ -1062,6 +1144,9 @@ Perl_newIO(pTHX) sv_upgrade((SV *)io,SVt_PVIO); SvREFCNT(io) = 1; SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a + package name */ + hv_clear(PL_stashcache); iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) @@ -1083,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 */ @@ -1113,7 +1198,7 @@ Perl_gv_check(pTHX_ HV *stash) #else CopFILEGV(PL_curcop) = gv_fetchfile(file); #endif - Perl_warner(aTHX_ WARN_ONCE, + Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } @@ -1160,8 +1245,9 @@ Perl_gp_free(pTHX_ GV *gv) return; if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, - "Attempt to free unreferenced glob pointers"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_cv) { @@ -1174,41 +1260,23 @@ 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_sv) 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; } -#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286)) -#define MICROPORT -#endif - -#ifdef MICROPORT /* Microport 2.4 hack */ -AV *GvAVn(gv) -register GV *gv; -{ - if (GvGP(gv)->gp_av) - return GvGP(gv)->gp_av; - else - return GvGP(gv_AVadd(gv))->gp_av; -} - -HV *GvHVn(gv) -register GV *gv; -{ - if (GvGP(gv)->gp_hv) - return GvGP(gv)->gp_hv; - else - return GvGP(gv_HVadd(gv))->gp_hv; -} -#endif /* Microport 2.4 hack */ - int Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) { @@ -1239,7 +1307,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) if (mg && amtp->was_ok_am == PL_amagic_generation && amtp->was_ok_sub == PL_sub_generation) - return AMT_OVERLOADED(amtp); + return (bool)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)) ); @@ -1279,30 +1347,41 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) 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, cooky, l, -1); + /* don't fill the cache while looking up! + Creation of inheritance stubs in intermediate packages may + conflict with the logic of runtime method substitution. + Indeed, for inheritance A -> B -> C, if C overloads "+0", + then we could have created stubs for "(+0" in A and C too. + But if B overloads "bool", we may want to use it for + numifying instead of C's "+0". */ + if (i >= DESTROY_amg) + gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0); + else /* Autoload taken care of below */ + gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + /* This is a hack to support autoloading..., while + knowing *which* methods were declared as overloaded. */ /* GvSV contains the name of the method. */ - GV *ngv; + GV *ngv = Nullgv; - DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) ); + 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)), FALSE))) { /* Can be an import stub (created by `can'). */ - if (GvCVGEN(gv)) { - Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", - (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), - cp, HvNAME(stash)); - } else - Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'", - (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), - cp, HvNAME(stash)); + SV *gvsv = GvSV(gv); + const char *name = SvPOK(gvsv) ? SvPVX(gvsv) : "???"; + Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\ + "in package `%.256s'", + (GvCVGEN(gv) ? "Stub found while resolving" + : "Can't resolve"), + name, cp, HvNAME(stash)); } cv = GvCV(gv = ngv); } @@ -1312,6 +1391,9 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) filled = 1; if (i < DESTROY_amg) have_ovl = 1; + } else if (gv) { /* Autoloaded... */ + cv = (CV*)gv; + filled = 1; } amt.table[i]=(CV*)SvREFCNT_inc(cv); } @@ -1338,8 +1420,9 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) { MAGIC *mg; AMT *amtp; + CV *ret; - if (!stash) + if (!stash || !HvNAME(stash)) return Nullcv; mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); if (!mg) { @@ -1351,8 +1434,21 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) 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]; + if (AMT_AMAGIC(amtp)) { + ret = amtp->table[id]; + if (ret && isGV(ret)) { /* Autoloading stab */ + /* Passing it through may have resulted in a warning + "Inherited AUTOLOAD for a non-method deprecated", since + our caller is going through a function call, not a method call. + So return the CV for AUTOLOAD, setting $AUTOLOAD. */ + GV *gv = gv_fetchmethod(stash, (char*)PL_AMG_names[id]); + + if (gv && GvCV(gv)) + return GvCV(gv); + } + return ret; + } + return Nullcv; } @@ -1733,15 +1829,18 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) break; case '\017': /* $^O & $^OPEN */ if (len == 1 - || (len == 4 && strEQ(name, "\027PEN"))) + || (len == 4 && strEQ(name, "\017PEN"))) { goto yes; } break; + case '\025': + if (len > 1 && strEQ(name, "\025NICODE")) + goto yes; case '\027': /* $^W & $^WARNING_BITS */ if (len == 1 || (len == 12 && strEQ(name, "\027ARNING_BITS")) - || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS"))) + ) { goto yes; } @@ -1755,7 +1854,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '!': case '-': case '#': - case '*': case '[': case '^': case '~': @@ -1784,11 +1882,14 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) case '\016': /* $^N */ case '\020': /* $^P */ case '\023': /* $^S */ - case '\024': /* $^T */ case '\026': /* $^V */ if (len == 1) goto yes; break; + case '\024': /* $^T, ${^TAINT} */ + if (len == 1 || strEQ(name, "\024AINT")) + goto yes; + break; case '1': case '2': case '3':