X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=3ab1935ec653cdbeae50e68d3f369c65e07c837b;hb=1fb76a4637fd4800180784d4acf2abcdd008365e;hp=f0e685bf81dd89e64138982c7002c57c870c636d;hpb=0ac0412a111b224c7f0c310960dde8b2a3fdad89;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index f0e685b..3ab1935 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,6 @@ /* gv.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -16,6 +16,10 @@ * laughed Pippin. */ +/* +=head1 GV Functions +*/ + #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" @@ -257,7 +261,7 @@ 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", + Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } @@ -306,6 +310,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. @@ -374,9 +422,17 @@ 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); + } } gv = gv_fetchmeth(stash, name, nend - name, 0); @@ -434,9 +490,9 @@ 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); @@ -494,7 +550,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); @@ -595,7 +652,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); @@ -657,7 +714,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) strEQ(name, "ARGVOUT"))) global = TRUE; } - else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__"))) + else if (*name == '_' && !name[1]) global = TRUE; if (global) @@ -737,7 +794,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); @@ -869,8 +926,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) 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 (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); /* FALL THROUGH */ case '[': case '^': @@ -1124,7 +1181,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)); } @@ -1171,7 +1228,7 @@ Perl_gp_free(pTHX_ GV *gv) return; if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced glob pointers"); return; } @@ -1196,30 +1253,6 @@ Perl_gp_free(pTHX_ GV *gv) 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) { @@ -1250,7 +1283,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)) ); @@ -1290,14 +1323,25 @@ 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)) ); @@ -1323,6 +1367,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); } @@ -1349,6 +1396,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id) { MAGIC *mg; AMT *amtp; + CV *ret; if (!stash) return Nullcv; @@ -1362,8 +1410,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; } @@ -1744,7 +1805,7 @@ 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; }