X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/22c35a8c2392967a5ba6b5370695be464bd7012c..938c8732ceb115a707f725327a631eb35319ba87:/gv.c diff --git a/gv.c b/gv.c index 1d24fa4..d1ba5a3 100644 --- a/gv.c +++ b/gv.c @@ -1,6 +1,7 @@ /* gv.c * - * Copyright (c) 1991-1997, 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,73 +17,85 @@ * laughed Pippin. */ +/* +=head1 GV Functions +*/ + #include "EXTERN.h" +#define PERL_IN_GV_C #include "perl.h" GV * -gv_AVadd(register GV *gv) +Perl_gv_AVadd(pTHX_ register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - croak("Bad symbol for array"); + Perl_croak(aTHX_ "Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); return gv; } GV * -gv_HVadd(register GV *gv) +Perl_gv_HVadd(pTHX_ register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - croak("Bad symbol for hash"); + Perl_croak(aTHX_ "Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); return gv; } GV * -gv_IOadd(register GV *gv) +Perl_gv_IOadd(pTHX_ register GV *gv) { if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - croak("Bad symbol for filehandle"); - if (!GvIOp(gv)) + Perl_croak(aTHX_ "Bad symbol for filehandle"); + 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 * -gv_fetchfile(char *name) +Perl_gv_fetchfile(pTHX_ const char *name) { - dTHR; char smallbuf[256]; char *tmpbuf; STRLEN tmplen; GV *gv; + if (!PL_defstash) + return Nullgv; + tmplen = strlen(name) + 2; if (tmplen < sizeof smallbuf) 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); gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); - if (!isGV(gv)) + if (!isGV(gv)) { gv_init(gv, PL_defstash, tmpbuf, tmplen, FALSE); + sv_setpv(GvSV(gv), name); + if (PERLDB_LINE) + hv_magic(GvHVn(gv_AVadd(gv)), Nullgv, PERL_MAGIC_dbfile); + } if (tmpbuf != smallbuf) Safefree(tmpbuf); - sv_setpv(GvSV(gv), name); - if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm"))) - GvMULTI_on(gv); - if (PERLDB_LINE) - hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L'); return gv; } void -gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) +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; @@ -99,34 +112,28 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) Newz(602, gp, 1, GP); GvGP(gv) = gp_ref(gp); GvSV(gv) = NEWSV(72,0); - GvLINE(gv) = PL_curcop->cop_line; - GvFILEGV(gv) = PL_curcop->cop_filegv; + GvLINE(gv) = CopLINE(PL_curcop); + GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : ""; GvCVGEN(gv) = 0; GvEGV(gv) = gv; - sv_magic((SV*)gv, (SV*)gv, '*', name, len); + 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; - if (multi) + if (multi || doproto) /* doproto means it _was_ mentioned */ GvMULTI_on(gv); if (doproto) { /* Replicate part of newSUB here. */ SvIOK_off(gv); ENTER; + /* XXX unsafe for threads if eval_owner isn't held */ start_subparse(0,0); /* Create CV in compcv. */ GvCV(gv) = PL_compcv; LEAVE; PL_sub_generation++; - CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv); - CvFILEGV(GvCV(gv)) = PL_curcop->cop_filegv; + CvGV(GvCV(gv)) = gv; + CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; -#ifdef USE_THREADS - CvOWNER(GvCV(gv)) = 0; - if (!CvMUTEXP(GvCV(gv))) { - New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(GvCV(gv))); - } -#endif /* USE_THREADS */ if (proto) { sv_setpv((SV*)GvCV(gv), proto); Safefree(proto); @@ -135,7 +142,7 @@ gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi) } STATIC void -gv_init_sv(GV *gv, I32 sv_type) +S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) { switch (sv_type) { case SVt_PVIO: @@ -150,8 +157,29 @@ gv_init_sv(GV *gv, I32 sv_type) } } +/* +=for apidoc gv_fetchmeth + +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::. + +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 +which in the case of success contains an alias for the subroutine, and sets +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 +the GV directly; instead, you should use the method's CV, which can be +obtained from the GV with the C macro. + +=cut +*/ + GV * -gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) +Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { AV* av; GV* topgv; @@ -159,13 +187,22 @@ gv_fetchmeth(HV *stash, 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 (!HvNAME(stash)) + Perl_croak(aTHX_ + "Can't use anonymous symbol table for method lookup"); + if ((level > 100) || (level < -100)) - croak("Recursive inheritance detected while looking for method '%s' in package '%s'", + Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'", name, HvNAME(stash)); - DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); if (!gvp) @@ -174,7 +211,7 @@ gv_fetchmeth(HV *stash, 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; @@ -202,10 +239,9 @@ gv_fetchmeth(HV *stash, 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)) - croak("Cannot create %s::ISA", HvNAME(stash)); + Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash)); if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, "ISA", 3, TRUE); SvREFCNT_dec(GvAV(gv)); @@ -222,10 +258,9 @@ gv_fetchmeth(HV *stash, 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)) - warner(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, @@ -240,9 +275,10 @@ gv_fetchmeth(HV *stash, 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: @@ -254,7 +290,7 @@ gv_fetchmeth(HV *stash, 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; @@ -271,20 +307,103 @@ gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) return 0; } +/* +=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. + +=cut +*/ + GV * -gv_fetchmethod(HV *stash, char *name) +Perl_gv_fetchmethod(pTHX_ HV *stash, const char *name) { return gv_fetchmethod_autoload(stash, name, TRUE); } +/* +=for apidoc gv_fetchmethod_autoload + +Returns the glob which contains the subroutine to call to invoke the method +on the C. In fact in the presence of autoloading this may be the +glob for "AUTOLOAD". In this case the corresponding variable $AUTOLOAD is +already setup. + +The third parameter of C determines whether +AUTOLOAD lookup is performed if the given method is not present: non-zero +means yes, look for AUTOLOAD; zero means no, don't look for AUTOLOAD. +Calling C is equivalent to calling C +with a non-zero C parameter. + +These functions grant C<"SUPER"> token as a prefix of the method name. Note +that if you want to keep the returned glob for a long time, you need to +check for it being "AUTOLOAD", since at the later time the call may load a +different subroutine due to $AUTOLOAD changing its value. Use the glob +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. + +=cut +*/ + GV * -gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload) +Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { - dTHR; - register char *nend; - char *nsplit = 0; + 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 == '\'') nsplit = nend; @@ -292,28 +411,39 @@ gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload) nsplit = ++nend; } if (nsplit) { - char *origname = name; + const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER", - HvNAME(PL_curcop->cop_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( deb("Treating %s as %s::%s\n", + DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } - else - stash = gv_stashpvn(origname, nsplit - origname, TRUE); + 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); if (!gv) { - if (strEQ(name,"import")) + 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); @@ -339,31 +469,55 @@ gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload) } GV* -gv_autoload4(HV *stash, char *name, STRLEN len, I32 method) +Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { - dTHR; - 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 (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); + if (!(CvROOT(cv) || CvXSUB(cv))) + return Nullgv; + /* * 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)) - warner(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); + + 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; + } /* * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name. @@ -373,24 +527,61 @@ gv_autoload4(HV *stash, char *name, STRLEN len, I32 method) */ varstash = GvSTASH(CvGV(cv)); vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + ENTER; + if (!isGV(vargv)) gv_init(vargv, varstash, autoload, autolen, FALSE); + LEAVE; varsv = GvSV(vargv); - sv_setpv(varsv, HvNAME(stash)); + sv_setpv(varsv, packname); sv_catpvn(varsv, "::", 2); sv_catpvn(varsv, name, len); SvTAINTED_off(varsv); 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 $! */ + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn("Errno",5), Nullsv); + 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 + +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 +*/ + HV* -gv_stashpv(char *name, I32 create) +Perl_gv_stashpv(pTHX_ const char *name, I32 create) { return gv_stashpvn(name, strlen(name), create); } HV* -gv_stashpvn(char *name, U32 namelen, I32 create) +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) { char smallbuf[256]; char *tmpbuf; @@ -418,8 +609,17 @@ gv_stashpvn(char *name, U32 namelen, I32 create) return stash; } +/* +=for apidoc gv_stashsv + +Returns a pointer to the stash for a specified package, which must be a +valid UTF-8 string. See C. + +=cut +*/ + HV* -gv_stashsv(SV *sv, I32 create) +Perl_gv_stashsv(pTHX_ SV *sv, I32 create) { register char *ptr; STRLEN len; @@ -429,23 +629,21 @@ gv_stashsv(SV *sv, I32 create) GV * -gv_fetchpv(char *nambeg, I32 add, I32 sv_type) +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - dTHR; - register char *name = nambeg; + register const char *name = nambeg; register GV *gv = 0; GV**gvp; I32 len; - register char *namend; + register const char *namend; HV *stash = 0; - U32 add_gvflags = 0; if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ name++; for (namend = name; *namend; namend++) { - if ((*namend == '\'' && namend[1]) || - (*namend == ':' && namend[1] == ':')) + if ((*namend == ':' && namend[1] == ':') + || (*namend == '\'' && namend[1])) { if (!stash) stash = PL_defstash; @@ -457,7 +655,7 @@ gv_fetchpv(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); @@ -494,15 +692,15 @@ gv_fetchpv(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 */ if (!stash) { - if (isIDFIRST(*name) - || (IN_UTF8 && ((*name & 0xc0) == 0xc0) && isIDFIRST_utf8((U8*)name))) - { + if (isIDFIRST_lazy(name)) { bool global = FALSE; if (isUPPER(*name)) { @@ -526,7 +724,7 @@ gv_fetchpv(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 && @@ -542,22 +740,22 @@ gv_fetchpv(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)) ) { - warn("Variable \"%c%s\" is not imported", + Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', name); if (GvCVu(*gvp)) - warn("(Did you mean &%s instead?)\n", name); + Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); stash = 0; } } } else - stash = PL_curcop->cop_stash; + stash = CopSTASH(PL_curcop); } else stash = PL_defstash; @@ -566,26 +764,20 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) /* By this point we should have a stash and a name */ if (!stash) { - if (!add) - return Nullgv; - { - char sv_type_char = ((sv_type == SVt_PV) ? '$' - : (sv_type == SVt_PVAV) ? '@' - : (sv_type == SVt_PVHV) ? '%' - : 0); - if (sv_type_char) - warn("Global symbol \"%c%s\" requires explicit package name", - sv_type_char, name); - else - warn("Global symbol \"%s\" requires explicit package name", - name); + if (add) { + 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); + if (USE_UTF8_IN_NAMES) + SvUTF8_on(err); + qerror(err); + stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); } - ++PL_error_count; - stash = PL_curstash ? PL_curstash : PL_defstash; /* avoid core dumps */ - add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV - : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV - : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV - : 0); + else + return Nullgv; } if (!SvREFCNT(stash)) /* symbol table under destruction */ @@ -599,6 +791,8 @@ gv_fetchpv(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) { @@ -607,11 +801,14 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) /* Adding a new symbol */ - if (add & GV_ADDWARN) - warn("Had to create %s unexpectedly", nambeg); + if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) + 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); - GvFLAGS(gv) |= add_gvflags; + + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + : (PL_dowarn & G_WARN_ON ) ) ) + GvMULTI_on(gv) ; /* set up magic where warranted */ switch (*name) { @@ -620,12 +817,6 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } break; - - case 'a': - case 'b': - if (len == 1) - GvMULTI_on(gv); - break; case 'E': if (strnEQ(name, "EXPORT", 6)) GvMULTI_on(gv); @@ -634,71 +825,71 @@ gv_fetchpv(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) { char *pname; - av_push(av, newSVpv(pname = "NDBM_File",0)); + av_push(av, newSVpvn(pname = "NDBM_File",9)); gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpv(pname = "DB_File",0)); + av_push(av, newSVpvn(pname = "DB_File",7)); gv_stashpvn(pname, 7, TRUE); - av_push(av, newSVpv(pname = "GDBM_File",0)); + av_push(av, newSVpvn(pname = "GDBM_File",9)); gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpv(pname = "SDBM_File",0)); + av_push(av, newSVpvn(pname = "SDBM_File",9)); gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpv(pname = "ODBM_File",0)); + av_push(av, newSVpvn(pname = "ODBM_File",9)); gv_stashpvn(pname, 9, TRUE); } } break; -#ifdef OVERLOAD case 'O': if (strEQ(name, "OVERLOAD")) { HV* hv = GvHVn(gv); GvMULTI_on(gv); - hv_magic(hv, gv, 'A'); + hv_magic(hv, Nullgv, PERL_MAGIC_overload); } break; -#endif /* OVERLOAD */ case 'S': if (strEQ(name, "SIG")) { HV *hv; I32 i; - PL_siggv = gv; - GvMULTI_on(PL_siggv); - hv = GvHVn(PL_siggv); - hv_magic(hv, PL_siggv, 'S'); - for(i=1;PL_sig_name[i];i++) { + if (!PL_psig_ptr) { + 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, 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); + 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; + case 'V': + if (strEQ(name, "VERSION")) + GvMULTI_on(gv); + break; case '&': - if (len > 1) - break; - PL_ampergv = gv; - PL_sawampersand = TRUE; - goto ro_magicalize; - case '`': - if (len > 1) - break; - PL_leftgv = gv; - PL_sawampersand = TRUE; - goto ro_magicalize; - case '\'': - if (len > 1) - break; - PL_rightgv = gv; + if ( + len > 1 || + sv_type == SVt_PVAV || + sv_type == SVt_PVHV || + sv_type == SVt_PVCV || + sv_type == SVt_PVFM || + sv_type == SVt_PVIO + ) { break; } PL_sawampersand = TRUE; goto ro_magicalize; @@ -712,38 +903,44 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) if (len > 1) break; #ifdef COMPLEX_STATUS - sv_upgrade(GvSV(gv), SVt_PVLV); + (void)SvUPGRADE(GvSV(gv), SVt_PVLV); #endif goto magicalize; 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; - perl_require_pv("Errno.pm"); - SPAGAIN; - stash = gv_stashpvn("Errno",5,FALSE); - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) - croak("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; - case '#': case '*': - if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) - warner(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 '^': @@ -758,32 +955,61 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case ',': case '\\': case '/': + case '\001': /* $^A */ + case '\003': /* $^C */ + case '\004': /* $^D */ + case '\006': /* $^F */ + case '\010': /* $^H */ + case '\011': /* $^I, NOT \t in EBCDIC */ + case '\016': /* $^N */ + case '\020': /* $^P */ + if (len > 1) + break; + goto magicalize; case '|': - case '\001': - case '\002': - case '\004': - case '\005': - case '\006': - case '\010': - case '\011': /* NOT \t in EBCDIC */ - case '\017': - case '\020': - case '\024': - case '\027': if (len > 1) 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; goto magicalize; - case '\023': + case '\023': /* $^S */ 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") + ) + break; + goto magicalize; case '+': if (len > 1) 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 */ case '1': @@ -795,13 +1021,24 @@ gv_fetchpv(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': + case '\014': /* $^L */ if (len > 1) break; sv_setpv(GvSV(gv),"\f"); @@ -815,57 +1052,91 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case ']': if (len == 1) { SV *sv = GvSV(gv); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, PL_patchlevel); - (void)sv_2nv(sv); + (void)SvUPGRADE(sv, SVt_PVNV); + Perl_sv_setpvf(aTHX_ sv, +#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0) + "%8.6" +#else + "%5.3" +#endif + NVff, + SvNVX(PL_patchlevel)); + SvNVX(sv) = SvNVX(PL_patchlevel); + SvNOK_on(sv); SvREADONLY_on(sv); } break; + case '\026': /* $^V */ + if (len == 1) { + SV *sv = GvSV(gv); + GvSV(gv) = SvREFCNT_inc(PL_patchlevel); + SvREFCNT_dec(sv); + } + break; } return gv; } void -gv_fullname3(SV *sv, GV *gv, char *prefix) +Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) { + char *name; HV *hv = GvSTASH(gv); if (!hv) { - SvOK_off(sv); + (void)SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); - sv_catpv(sv,HvNAME(hv)); - sv_catpvn(sv,"::", 2); + + 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)); } void -gv_efullname3(SV *sv, GV *gv, char *prefix) +Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix) +{ + gv_fullname4(sv, gv, prefix, TRUE); +} + +void +Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain) { GV *egv = GvEGV(gv); if (!egv) egv = gv; - gv_fullname3(sv, egv, prefix); + gv_fullname4(sv, egv, prefix, keepmain); +} + +void +Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix) +{ + gv_efullname4(sv, gv, prefix, TRUE); } /* XXX compatibility with versions <= 5.003. */ void -gv_fullname(SV *sv, GV *gv) +Perl_gv_fullname(pTHX_ SV *sv, GV *gv) { gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : ""); } /* XXX compatibility with versions <= 5.003. */ void -gv_efullname(SV *sv, GV *gv) +Perl_gv_efullname(pTHX_ SV *sv, GV *gv) { gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : ""); } IO * -newIO(void) +Perl_newIO(pTHX) { - dTHR; IO *io; GV *iogv; @@ -873,43 +1144,61 @@ newIO(void) 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); - if (!iogv) + /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ + if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv)); return io; } void -gv_check(HV *stash) +Perl_gv_check(pTHX_ HV *stash) { - dTHR; register HE *entry; register I32 i; register GV *gv; HV *hv; - GV *filegv; if (!HvARRAY(stash)) return; 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)) && isGV(gv) && (hv = GvHV(gv))) { - if (hv != PL_defstash) + if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } else if (isALPHA(*HeKEY(entry))) { + char *file; gv = (GV*)HeVAL(entry); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; - PL_curcop->cop_line = GvLINE(gv); - filegv = GvFILEGV(gv); - PL_curcop->cop_filegv = filegv; - if (filegv && GvMULTI(filegv)) /* Filename began with slash */ + file = GvFILE(gv); + /* performance hack: if filename is absolute and it's a standard + * module, don't bother warning */ + if (file + && PERL_FILE_IS_ABSOLUTE(file) +#ifdef MACOS_TRADITIONAL + && (instr(file, ":lib:") +#else + && (instr(file, "/lib/") +#endif + || instr(file, ".pm"))) + { continue; - warner(WARN_ONCE, + } + CopLINE_set(PL_curcop, GvLINE(gv)); +#ifdef USE_ITHREADS + CopFILE(PL_curcop) = file; /* set for warning */ +#else + CopFILEGV(PL_curcop) = gv_fetchfile(file); +#endif + Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } @@ -918,17 +1207,19 @@ gv_check(HV *stash) } GV * -newGVgen(char *pack) +Perl_newGVgen(pTHX_ char *pack) { - return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)PL_gensym++), + return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), TRUE, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ GP* -gp_ref(GP *gp) +Perl_gp_ref(pTHX_ GP *gp) { + if (!gp) + return (GP*)NULL; gp->gp_refcnt++; if (gp->gp_cv) { if (gp->gp_cvgen) { @@ -946,15 +1237,17 @@ gp_ref(GP *gp) } void -gp_free(GV *gv) +Perl_gp_free(pTHX_ GV *gv) { GP* gp; - CV* cv; if (!gv || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { - warn("Attempt to free unreferenced glob pointers"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced glob pointers" + pTHX__FORMAT pTHX__VALUE); return; } if (gp->gp_cv) { @@ -967,221 +1260,226 @@ gp_free(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; } -#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; +int +Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) { - 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; + 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; } -#endif /* Microport 2.4 hack */ -#ifdef OVERLOAD /* Updates and caches the CV's */ bool -Gv_AMupdate(HV *stash) +Perl_Gv_AMupdate(pTHX_ HV *stash) { - dTHR; - GV** gvp; - HV* hv; 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; 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 (bool)AMT_OVERLOADED(amtp); + sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); - DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) ); + 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, PL_na)); - if (gv) cv = GvCV(gv); - break; - } - cv = (CV*)SvRV(sv); - if (SvTYPE(cv) == SVt_PVCV) - break; - /* FALL THROUGH */ - case SVt_PVHV: - case SVt_PVAV: - croak("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, TRUE); - break; - } - if (cv) filled=1; - else { - croak("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; - SV** svp; /* 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; - } - - for (i = 1; i < NofAMmeth; i++) { - SV *cookie = sv_2mortal(newSVpvf("(%s", cp = PL_AMG_names[i])); - DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n", + /* 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); + + 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); + /* 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 (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( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", - SvPV(GvSV(gv), PL_na), cp, HvNAME(stash)) ); - if (!SvPOK(GvSV(gv)) + 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)) { - croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", - (SvPOK(GvSV(gv)) ? SvPVX(GvSV(gv)) : "???" ), - cp, HvNAME(stash)); - } else - croak("Cannot 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); } - DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", + DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; + if (i < DESTROY_amg) + have_ovl = 1; + } else if (gv) { /* Autoloaded... */ + cv = (CV*)gv; + filled = 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; + CV *ret; + + if (!stash || !HvNAME(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)) { + 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; +} + + SV* -amagic_call(SV *left, SV *right, int method, int flags) +Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { - dTHR; - MAGIC *mg; - CV *cv; + MAGIC *mg; + 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')) - && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + && (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]) + && ((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) { @@ -1214,7 +1512,7 @@ amagic_call(SV *left, SV *right, int method, int flags) (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; case not_amg: - (void)((cv = cvp[off=bool__amg]) + (void)((cv = cvp[off=bool__amg]) || (cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])); postpr = 1; @@ -1239,7 +1537,7 @@ amagic_call(SV *left, SV *right, int method, int flags) } break; case abs_amg: - if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + if ((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) { SV* nullsv=sv_2mortal(newSViv(0)); if (off1==lt_amg) { @@ -1263,26 +1561,40 @@ amagic_call(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; } break; + case int_amg: + case iter_amg: /* XXXX Eventually should do to_gv. */ + /* FAIL safe */ + return NULL; /* Delegate operation to standard mechanisms. */ + break; + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + break; default: goto not_found; } if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) - && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c')) - && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) + && (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)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; - } else if (((ocvp && oamtp->fallback > AMGfallNEVER - && (cvp=ocvp) && (lr = -1)) + } else if (((ocvp && oamtp->fallback > AMGfallNEVER + && (cvp=ocvp) && (lr = -1)) || (cvp && amtp->fallback > AMGfallNEVER && (lr=1))) && !(flags & AMGf_unary)) { /* We look for substitution for @@ -1315,6 +1627,16 @@ amagic_call(SV *left, SV *right, int method, int flags) } } else { not_found: /* No method found, either report or croak */ + switch (method) { + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + /* FAIL safe */ + return left; /* Delegate operation to standard mechanisms. */ + break; + } if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */ notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { @@ -1322,49 +1644,51 @@ amagic_call(SV *left, SV *right, int method, int flags) } else { SV *msg; if (off==-1) off=method; - msg = sv_2mortal(newSVpvf( + 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)? + SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", - SvAMAGIC(left)? + SvAMAGIC(left)? HvNAME(SvSTASH(SvRV(left))): "", - SvAMAGIC(right)? + SvAMAGIC(right)? ",\n\tright argument in overloaded package ": - (flags & AMGf_unary + (flags & AMGf_unary ? "" : ",\n\tright argument has no overloaded magic"), - SvAMAGIC(right)? + SvAMAGIC(right)? HvNAME(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { - DEBUG_o( deb("%s", SvPVX(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); } else { - croak("%_", msg); + Perl_croak(aTHX_ "%"SVf, msg); } return NULL; } force_cpy = force_cpy || assign; } } +#ifdef DEBUGGING if (!notfound) { - DEBUG_o( deb( - "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 @@ -1375,10 +1699,10 @@ amagic_call(SV *left, SV *right, int method, int flags) * b) Increment or decrement, called directly. * assignshift==0, assign==0, method + 0 == off * c) Increment or decrement, translated to assignment add/subtr. - * assignshift==0, assign==T, + * assignshift==0, assign==T, * force_cpy == T * d) Increment or decrement, translated to nomethod. - * assignshift==0, assign==0, + * assignshift==0, assign==0, * force_cpy == T * e) Assignment form translated to nomethod. * assignshift==1, assign==T, method + 1 != off @@ -1410,29 +1734,30 @@ amagic_call(SV *left, SV *right, int method, int flags) if (PERLDB_SUB && PL_curstash != PL_debstash) PL_op->op_private |= OPpENTERSUB_DB; PUTBACK; - pp_pushmark(ARGS); + pp_pushmark(); EXTEND(SP, notfound + 5); PUSHs(lr>0? right: left); 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; - if (PL_op = pp_entersub(ARGS)) - CALLRUNOPS(); + if ((PL_op = Perl_pp_entersub(aTHX))) + CALLRUNOPS(aTHX); LEAVE; SPAGAIN; res=POPs; + PUTBACK; POPSTACK; CATCH_SET(oldcatch); if (postpr) { - int ans; + int ans=0; switch (method) { case le_amg: case sle_amg: @@ -1456,12 +1781,12 @@ amagic_call(SV *left, SV *right, int method, int flags) case dec_amg: SvSetSV(left,res); return left; case not_amg: - ans=!SvOK(res); break; + ans=!SvTRUE(res); break; } return boolSV(ans); } else if (method==copy_amg) { if (!SvROK(res)) { - croak("Copy method did not return a reference"); + Perl_croak(aTHX_ "Copy method did not return a reference"); } return SvREFCNT_inc(SvRV(res)); } else { @@ -1469,5 +1794,122 @@ amagic_call(SV *left, SV *right, int method, int flags) } } } -#endif /* OVERLOAD */ +/* +=for apidoc is_gv_magical + +Returns C if given the name of a magical GV. + +Currently only useful internally when determining if a GV should be +created even in rvalue contexts. + +C is not used at present but available for future extension to +allow selecting particular classes of magical variable. + +=cut +*/ +bool +Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags) +{ + if (!len) + return FALSE; + + switch (*name) { + case 'I': + if (len == 3 && strEQ(name, "ISA")) + goto yes; + break; + case 'O': + if (len == 8 && strEQ(name, "OVERLOAD")) + goto yes; + break; + case 'S': + if (len == 3 && strEQ(name, "SIG")) + goto yes; + break; + case '\017': /* $^O & $^OPEN */ + if (len == 1 + || (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")) + ) + { + goto yes; + } + break; + + case '&': + case '`': + case '\'': + case ':': + case '?': + case '!': + case '-': + case '#': + case '[': + case '^': + case '~': + case '=': + case '%': + case '.': + case '(': + case ')': + case '<': + case '>': + case ',': + case '\\': + case '/': + case '|': + case '+': + case ';': + case ']': + 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 '\014': /* $^L */ + case '\016': /* $^N */ + case '\020': /* $^P */ + case '\023': /* $^S */ + 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': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (len > 1) { + char *end = name + len; + while (--end > name) { + if (!isDIGIT(*end)) + return FALSE; + } + } + yes: + return TRUE; + default: + break; + } + return FALSE; +}