X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=74a9b2ecad107ad2a14614845ef0ae69adc33eb1;hb=e9c9f4ae5f2d0d58e16bec3b528c1d6eec0c2716;hp=8ea4171d2ad60c9938f13dfc4824c88e4394c1ca;hpb=27da23d53ccce622bc51822f59df8def79b4df95;p=p5sagit%2Fp5-mst-13.2.git diff --git a/gv.c b/gv.c index 8ea4171..74a9b2e 100644 --- a/gv.c +++ b/gv.c @@ -1,7 +1,7 @@ /* gv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -10,11 +10,13 @@ /* * 'Mercy!' cried Gandalf. 'If the giving of information is to be the cure - * of your inquisitiveness, I shall spend all the rest of my days answering + * of your inquisitiveness, I shall spend all the rest of my days in answering * you. What more do you want to know?' * 'The names of all the stars, and of all living things, and the whole * history of Middle-earth and Over-heaven and of the Sundering Seas,' * laughed Pippin. + * + * [p.599 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* @@ -33,11 +35,32 @@ Perl stores its global variables. #include "EXTERN.h" #define PERL_IN_GV_C #include "perl.h" +#include "overload.c" + +static const char S_autoload[] = "AUTOLOAD"; +static const STRLEN S_autolen = sizeof(S_autoload)-1; + + +#ifdef PERL_DONT_CREATE_GVSV +GV * +Perl_gv_SVadd(pTHX_ GV *gv) +{ + PERL_ARGS_ASSERT_GV_SVADD; + + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) + Perl_croak(aTHX_ "Bad symbol for scalar"); + if (!GvSV(gv)) + GvSV(gv) = newSV(0); + return gv; +} +#endif GV * Perl_gv_AVadd(pTHX_ register GV *gv) { - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + PERL_ARGS_ASSERT_GV_AVADD; + + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for array"); if (!GvAV(gv)) GvAV(gv) = newAV(); @@ -47,7 +70,9 @@ Perl_gv_AVadd(pTHX_ register GV *gv) GV * Perl_gv_HVadd(pTHX_ register GV *gv) { - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) + PERL_ARGS_ASSERT_GV_HVADD; + + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) Perl_croak(aTHX_ "Bad symbol for hash"); if (!GvHV(gv)) GvHV(gv) = newHV(); @@ -57,8 +82,26 @@ Perl_gv_HVadd(pTHX_ register GV *gv) GV * Perl_gv_IOadd(pTHX_ register GV *gv) { - if (!gv || SvTYPE((SV*)gv) != SVt_PVGV) - Perl_croak(aTHX_ "Bad symbol for filehandle"); + dVAR; + + PERL_ARGS_ASSERT_GV_IOADD; + + if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) { + + /* + * if it walks like a dirhandle, then let's assume that + * this is a dirhandle. + */ + const char * const fh = + PL_op->op_type == OP_READDIR || + PL_op->op_type == OP_TELLDIR || + PL_op->op_type == OP_SEEKDIR || + PL_op->op_type == OP_REWINDDIR || + PL_op->op_type == OP_CLOSEDIR ? + "dirhandle" : "filehandle"; + Perl_croak(aTHX_ "Bad symbol for %s", fh); + } + if (!GvIOp(gv)) { #ifdef GV_UNIQUE_CHECK if (GvUNIQUE(gv)) { @@ -73,89 +116,200 @@ Perl_gv_IOadd(pTHX_ register GV *gv) GV * Perl_gv_fetchfile(pTHX_ const char *name) { - char smallbuf[256]; + PERL_ARGS_ASSERT_GV_FETCHFILE; + return gv_fetchfile_flags(name, strlen(name), 0); +} + +GV * +Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, + const U32 flags) +{ + dVAR; + char smallbuf[128]; char *tmpbuf; - STRLEN tmplen; + const STRLEN tmplen = namelen + 2; GV *gv; + PERL_ARGS_ASSERT_GV_FETCHFILE_FLAGS; + PERL_UNUSED_ARG(flags); + if (!PL_defstash) - return Nullgv; + return NULL; - tmplen = strlen(name) + 2; - if (tmplen < sizeof smallbuf) + if (tmplen <= sizeof smallbuf) tmpbuf = smallbuf; else - New(603, tmpbuf, tmplen + 1, char); + Newx(tmpbuf, tmplen, char); /* This is where the debugger's %{"::_<$filename"} hash is created */ tmpbuf[0] = '_'; tmpbuf[1] = '<'; - strcpy(tmpbuf + 2, name); + memcpy(tmpbuf + 2, name, namelen); gv = *(GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, TRUE); 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); +#ifdef PERL_DONT_CREATE_GVSV + GvSV(gv) = newSVpvn(name, namelen); +#else + sv_setpvn(GvSV(gv), name, namelen); +#endif + if (PERLDB_LINE || PERLDB_SAVESRC) + hv_magic(GvHVn(gv_AVadd(gv)), NULL, PERL_MAGIC_dbfile); } if (tmpbuf != smallbuf) Safefree(tmpbuf); return gv; } +/* +=for apidoc gv_const_sv + +If C is a typeglob whose subroutine entry is a constant sub eligible for +inlining, or C is a placeholder reference that would be promoted to such +a typeglob, then returns the value returned by the sub. Otherwise, returns +NULL. + +=cut +*/ + +SV * +Perl_gv_const_sv(pTHX_ GV *gv) +{ + PERL_ARGS_ASSERT_GV_CONST_SV; + + if (SvTYPE(gv) == SVt_PVGV) + return cv_const_sv(GvCVu(gv)); + return SvROK(gv) ? SvRV(gv) : NULL; +} + +GP * +Perl_newGP(pTHX_ GV *const gv) +{ + GP *gp; + U32 hash; +#ifdef USE_ITHREADS + const char *const file + = (PL_curcop && CopFILE(PL_curcop)) ? CopFILE(PL_curcop) : ""; + const STRLEN len = strlen(file); +#else + SV *const temp_sv = CopFILESV(PL_curcop); + const char *file; + STRLEN len; + + PERL_ARGS_ASSERT_NEWGP; + + if (temp_sv) { + file = SvPVX(temp_sv); + len = SvCUR(temp_sv); + } else { + file = ""; + len = 0; + } +#endif + + PERL_HASH(hash, file, len); + + Newxz(gp, 1, GP); + +#ifndef PERL_DONT_CREATE_GVSV + gp->gp_sv = newSV(0); +#endif + + gp->gp_line = PL_curcop ? CopLINE(PL_curcop) : 0; + /* XXX Ideally this cast would be replaced with a change to const char* + in the struct. */ + gp->gp_file_hek = share_hek(file, len, hash); + gp->gp_egv = gv; + gp->gp_refcnt = 1; + + return gp; +} + void Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi) { dVAR; - register GP *gp; - const bool doproto = SvTYPE(gv) > SVt_NULL; - char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const U32 old_type = SvTYPE(gv); + const bool doproto = old_type > SVt_NULL; + char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL; + const STRLEN protolen = proto ? SvCUR(gv) : 0; + SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL; + const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0; + + PERL_ARGS_ASSERT_GV_INIT; + assert (!(proto && has_constant)); + + if (has_constant) { + /* The constant has to be a simple scalar type. */ + switch (SvTYPE(has_constant)) { + case SVt_PVAV: + case SVt_PVHV: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVIO: + Perl_croak(aTHX_ "Cannot convert a reference to %s to typeglob", + sv_reftype(has_constant, 0)); + default: NOOP; + } + SvRV_set(gv, NULL); + SvROK_off(gv); + } - sv_upgrade((SV*)gv, SVt_PVGV); + + if (old_type < SVt_PVGV) { + if (old_type >= SVt_PV) + SvCUR_set(gv, 0); + sv_upgrade(MUTABLE_SV(gv), SVt_PVGV); + } if (SvLEN(gv)) { if (proto) { SvPV_set(gv, NULL); SvLEN_set(gv, 0); SvPOK_off(gv); } else - Safefree(SvPVX(gv)); + Safefree(SvPVX_mutable(gv)); } - Newz(602, gp, 1, GP); - GvGP(gv) = gp_ref(gp); - GvSV(gv) = NEWSV(72,0); - GvLINE(gv) = CopLINE(PL_curcop); - /* XXX Ideally this cast would be replaced with a change to const char* - in the struct. */ - GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(PL_curcop) : (char *) ""; - GvCVGEN(gv) = 0; - GvEGV(gv) = gv; - 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; + SvIOK_off(gv); + isGV_with_GP_on(gv); + + GvGP(gv) = Perl_newGP(aTHX_ gv); + GvSTASH(gv) = stash; + if (stash) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(stash), MUTABLE_SV(gv)); + gv_name_set(gv, name, len, GV_ADD); 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; + if (has_constant) { + /* newCONSTSUB takes ownership of the reference from us. */ + GvCV(gv) = newCONSTSUB(stash, name, has_constant); + /* If this reference was a copy of another, then the subroutine + must have been "imported", by a Perl space assignment to a GV + from a reference to CV. */ + if (exported_constant) + GvIMPORTED_CV_on(gv); + } else { + (void) start_subparse(0,0); /* Create empty CV in compcv. */ + GvCV(gv) = PL_compcv; + } LEAVE; - PL_sub_generation++; + mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar($) { (shift) } sub ASDF::baz($); *ASDF::baz = \&Foo::bar */ CvGV(GvCV(gv)) = gv; CvFILE_set_from_cop(GvCV(gv), PL_curcop); CvSTASH(GvCV(gv)) = PL_curstash; if (proto) { - sv_setpv((SV*)GvCV(gv), proto); - Safefree(proto); + sv_usepvn_flags(MUTABLE_SV(GvCV(gv)), proto, protolen, + SV_HAS_TRAILING_NUL); } } } STATIC void -S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) +S_gv_init_sv(pTHX_ GV *gv, const svtype sv_type) { + PERL_ARGS_ASSERT_GV_INIT_SV; + switch (sv_type) { case SVt_PVIO: (void)GvIOn(gv); @@ -166,6 +320,19 @@ S_gv_init_sv(pTHX_ GV *gv, I32 sv_type) case SVt_PVHV: (void)GvHVn(gv); break; +#ifdef PERL_DONT_CREATE_GVSV + case SVt_NULL: + case SVt_PVCV: + case SVt_PVFM: + case SVt_PVGV: + break; + default: + if(GvSVn(gv)) { + /* Work round what appears to be a bug in Sun C++ 5.8 2005/10/13 + If we just cast GvSVn(gv) to void, it ignores evaluating it for + its side effect */ + } +#endif } } @@ -179,7 +346,7 @@ 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. +up caching info for this glob. 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 @@ -190,130 +357,140 @@ obtained from the GV with the C macro. =cut */ +/* NOTE: No support for tied ISA */ + GV * Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) { - AV* av; - GV* topgv; - GV* gv; + dVAR; GV** gvp; - CV* cv; + AV* linear_av; + SV** linear_svp; + SV* linear_sv; + HV* cstash; + GV* candidate = NULL; + CV* cand_cv = NULL; + CV* old_cv; + GV* topgv = NULL; + const char *hvname; + I32 create = (level >= 0) ? 1 : 0; + I32 items; + STRLEN packlen; + U32 topgen_cmp; + + PERL_ARGS_ASSERT_GV_FETCHMETH; /* UNIVERSAL methods should be callable without a stash */ if (!stash) { - level = -1; /* probably appropriate */ - if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) + create = 0; /* probably appropriate */ + if(!(stash = gv_stashpvs("UNIVERSAL", 0))) 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)); - - DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) ); + assert(stash); + + hvname = HvNAME_get(stash); + if (!hvname) + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + + assert(hvname); + assert(name); + + DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) ); + + topgen_cmp = HvMROMETA(stash)->cache_gen + PL_sub_generation; + + /* check locally for a real method or a cache entry */ + gvp = (GV**)hv_fetch(stash, name, len, create); + if(gvp) { + topgv = *gvp; + assert(topgv); + if (SvTYPE(topgv) != SVt_PVGV) + gv_init(topgv, stash, name, len, TRUE); + if ((cand_cv = GvCV(topgv))) { + /* If genuine method or valid cache entry, use it */ + if (!GvCVGEN(topgv) || GvCVGEN(topgv) == topgen_cmp) { + return topgv; + } + else { + /* stale cache entry, junk it and move on */ + SvREFCNT_dec(cand_cv); + GvCV(topgv) = cand_cv = NULL; + GvCVGEN(topgv) = 0; + } + } + else if (GvCVGEN(topgv) == topgen_cmp) { + /* cache indicates no such method definitively */ + return 0; + } + } - gvp = (GV**)hv_fetch(stash, name, len, (level >= 0)); - if (!gvp) - topgv = Nullgv; + packlen = HvNAMELEN_get(stash); + if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { + HV* basestash; + packlen -= 7; + basestash = gv_stashpvn(hvname, packlen, GV_ADD); + linear_av = mro_get_linear_isa(basestash); + } else { - topgv = *gvp; - if (SvTYPE(topgv) != SVt_PVGV) - gv_init(topgv, stash, name, len, TRUE); - if ((cv = GvCV(topgv))) { - /* If genuine method or valid cache entry, use it */ - if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation) - return topgv; - /* Stale cached entry: junk it */ - SvREFCNT_dec(cv); - GvCV(topgv) = cv = Nullcv; - GvCVGEN(topgv) = 0; - } - else if (GvCVGEN(topgv) == PL_sub_generation) - return 0; /* cache indicates sub doesn't exist */ + linear_av = mro_get_linear_isa(stash); /* has ourselves at the top of the list */ } - gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); - av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav; - - /* create and re-create @.*::SUPER::ISA on demand */ - if (!av || !SvMAGIC(av)) { - char* packname = HvNAME(stash); - STRLEN packlen = strlen(packname); - - if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) { - HV* basestash; - - packlen -= 7; - 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))) { - gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE); - if (!gvp || !(gv = *gvp)) - 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)); - GvAV(gv) = (AV*)SvREFCNT_inc(av); - } - } - } + linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ + items = AvFILLp(linear_av); /* no +1, to skip over self */ + while (items--) { + linear_sv = *linear_svp++; + assert(linear_sv); + cstash = gv_stashsv(linear_sv, 0); + + if (!cstash) { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", + SVfARG(linear_sv), hvname); + continue; + } - if (av) { - SV** svp = AvARRAY(av); - /* NOTE: No support for tied ISA */ - I32 items = AvFILLp(av) + 1; - while (items--) { - SV* sv = *svp++; - HV* basestash = gv_stashsv(sv, FALSE); - if (!basestash) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", - sv, HvNAME(stash)); - continue; - } - gv = gv_fetchmeth(basestash, name, len, - (level >= 0) ? level + 1 : level - 1); - if (gv) - goto gotcha; - } + assert(cstash); + + gvp = (GV**)hv_fetch(cstash, name, len, 0); + if (!gvp) continue; + candidate = *gvp; + assert(candidate); + if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, name, len, TRUE); + if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { + /* + * Found real method, cache method in topgv if: + * 1. topgv has no synonyms (else inheritance crosses wires) + * 2. method isn't a stub (else AUTOLOAD fails spectacularly) + */ + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(cand_cv); + GvCV(topgv) = cand_cv; + GvCVGEN(topgv) = topgen_cmp; + } + return candidate; + } } - /* if at top level, try UNIVERSAL */ - - if (level == 0 || level == -1) { - HV* lastchance; + /* Check UNIVERSAL without caching */ + if(level == 0 || level == -1) { + candidate = gv_fetchmeth(NULL, name, len, 1); + if(candidate) { + cand_cv = GvCV(candidate); + if (topgv && (GvREFCNT(topgv) == 1) && (CvROOT(cand_cv) || CvXSUB(cand_cv))) { + if ((old_cv = GvCV(topgv))) SvREFCNT_dec(old_cv); + SvREFCNT_inc_simple_void_NN(cand_cv); + GvCV(topgv) = cand_cv; + GvCVGEN(topgv) = topgen_cmp; + } + return candidate; + } + } - 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: - * 1. topgv has no synonyms (else inheritance crosses wires) - * 2. method isn't a stub (else AUTOLOAD fails spectacularly) - */ - if (topgv && - GvREFCNT(topgv) == 1 && - (cv = GvCV(gv)) && - (CvROOT(cv) || CvXSUB(cv))) - { - if ((cv = GvCV(topgv))) - SvREFCNT_dec(cv); - GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); - GvCVGEN(topgv) = PL_sub_generation; - } - return gv; - } - else if (topgv && GvREFCNT(topgv) == 1) { - /* cache the fact that the method is not defined */ - GvCVGEN(topgv) = PL_sub_generation; - } - } + if (topgv && GvREFCNT(topgv) == 1) { + /* cache the fact that the method is not defined */ + GvCVGEN(topgv) = topgen_cmp; } return 0; @@ -337,47 +514,33 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le { GV *gv = gv_fetchmeth(stash, name, len, level); + PERL_ARGS_ASSERT_GV_FETCHMETH_AUTOLOAD; + 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; + return NULL; /* UNIVERSAL::AUTOLOAD could cause trouble */ + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; + if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return Nullgv; + return NULL; /* 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 NULL; return *gvp; } return gv; } /* -=for apidoc gv_fetchmethod - -See L. - -=cut -*/ - -GV * -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 @@ -405,47 +568,102 @@ C apply equally to these functions. =cut */ +STATIC HV* +S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen) +{ + AV* superisa; + GV** gvp; + GV* gv; + HV* stash; + + PERL_ARGS_ASSERT_GV_GET_SUPER_PKG; + + stash = gv_stashpvn(name, namelen, 0); + if(stash) return stash; + + /* If we must create it, give it an @ISA array containing + the real package this SUPER is for, so that it's tied + into the cache invalidation code correctly */ + stash = gv_stashpvn(name, namelen, GV_ADD); + gvp = (GV**)hv_fetchs(stash, "ISA", TRUE); + gv = *gvp; + gv_init(gv, stash, "ISA", 3, TRUE); + superisa = GvAVn(gv); + GvMULTI_on(gv); + sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); +#ifdef USE_ITHREADS + av_push(superisa, newSVpv(CopSTASHPV(PL_curcop), 0)); +#else + av_push(superisa, newSVhek(CopSTASH(PL_curcop) + ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); +#endif + + return stash; +} + GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { + PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD; + + return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0); +} + +/* Don't merge this yet, as it's likely to get a len parameter, and possibly + even a U32 hash */ +GV * +Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags) +{ + dVAR; register const char *nend; - const char *nsplit = 0; + const char *nsplit = NULL; GV* gv; HV* ostash = stash; + const char * const origname = name; + SV *const error_report = MUTABLE_SV(stash); + const U32 autoload = flags & GV_AUTOLOAD; + const U32 do_croak = flags & GV_CROAK; - if (stash && SvTYPE(stash) < SVt_PVHV) - stash = Nullhv; + PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS; + + if (SvTYPE(stash) < SVt_PVHV) + stash = NULL; + else { + /* The only way stash can become NULL later on is if nsplit is set, + which in turn means that there is no need for a SVt_PVHV case + the error reporting code. */ + } for (nend = name; *nend; nend++) { - if (*nend == '\'') + if (*nend == '\'') { nsplit = nend; - else if (*nend == ':' && *(nend + 1) == ':') - nsplit = ++nend; + name = nend + 1; + } + else if (*nend == ':' && *(nend + 1) == ':') { + nsplit = nend++; + name = nend + 1; + } } if (nsplit) { - const char *origname = name; - name = nsplit + 1; - if (*nsplit == ':') - --nsplit; - if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { + if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ - SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", + SV * const 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); + stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME(stash), name) ); + origname, HvNAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ - stash = gv_stashpvn(origname, nsplit - origname, FALSE); + stash = gv_stashpvn(origname, nsplit - origname, 0); /* 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_stashpvn(origname, nsplit - origname - 7, 0)) + stash = gv_get_super_pkg(origname, nsplit - origname); } ostash = stash; } @@ -453,12 +671,37 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) - gv = (GV*)&PL_sv_yes; + gv = MUTABLE_GV(&PL_sv_yes); else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); + if (!gv && do_croak) { + /* Right now this is exclusively for the benefit of S_method_common + in pp_hot.c */ + if (stash) { + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%.*s\"", + name, (int)HvNAMELEN_get(stash), HvNAME_get(stash)); + } + else { + STRLEN packlen; + const char *packname; + + if (nsplit) { + packlen = nsplit - origname; + packname = origname; + } else { + packname = SvPV_const(error_report, packlen); + } + + Perl_croak(aTHX_ + "Can't locate object method \"%s\" via package \"%.*s\"" + " (perhaps you forgot to load \"%.*s\"?)", + name, (int)packlen, packname, (int)packlen, packname); + } + } } else if (autoload) { - CV* cv = GvCV(gv); + CV* const cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; @@ -484,43 +727,46 @@ GV* Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) { dVAR; - char autoload[] = "AUTOLOAD"; - STRLEN autolen = sizeof(autoload)-1; GV* gv; CV* cv; HV* varstash; GV* vargv; SV* varsv; const char *packname = ""; + STRLEN packname_len = 0; + + PERL_ARGS_ASSERT_GV_AUTOLOAD4; - if (len == autolen && strnEQ(name, autoload, autolen)) - return Nullgv; + if (len == S_autolen && memEQ(name, S_autoload, S_autolen)) + return NULL; if (stash) { if (SvTYPE(stash) < SVt_PVHV) { - packname = SvPV_nolen((SV*)stash); - stash = Nullhv; + packname = SvPV_const(MUTABLE_SV(stash), packname_len); + stash = NULL; } else { - packname = HvNAME(stash); + packname = HvNAME_get(stash); + packname_len = HvNAMELEN_get(stash); } } - if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) - return Nullgv; + if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE))) + return NULL; cv = GvCV(gv); if (!(CvROOT(cv) || CvXSUB(cv))) - return Nullgv; + return NULL; /* * Inheriting AUTOLOAD for non-methods works ... for now. */ - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method && - (GvCVGEN(gv) || GvSTASH(gv) != stash)) + if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) + && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) + ) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", packname, (int)len, name); - if (CvXSUB(cv)) { + if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here * only to have the XSUB do another lookup for $AUTOLOAD * and split that value on the last '::', @@ -539,51 +785,75 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * original package to look up $AUTOLOAD. */ varstash = GvSTASH(CvGV(cv)); - vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE); + vargv = *(GV**)hv_fetch(varstash, S_autoload, S_autolen, TRUE); ENTER; - if (!isGV(vargv)) - gv_init(vargv, varstash, autoload, autolen, FALSE); + if (!isGV(vargv)) { + gv_init(vargv, varstash, S_autoload, S_autolen, FALSE); +#ifdef PERL_DONT_CREATE_GVSV + GvSV(vargv) = newSV(0); +#endif + } LEAVE; - varsv = GvSV(vargv); - sv_setpv(varsv, packname); - sv_catpvn(varsv, "::", 2); + varsv = GvSVn(vargv); + sv_setpvn(varsv, packname, packname_len); + sv_catpvs(varsv, "::"); 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. + +/* require_tie_mod() internal routine for requiring a module + * that implements the logic of automatical ties like %! and %- + * + * The "gv" parameter should be the glob. + * "varpv" holds the name of the var, used for error messages. + * "namesv" holds the module name. Its refcount will be decremented. + * "methpv" holds the method name to test for to check that things + * are working reasonably close to as expected. + * "flags": if flag & 1 then save the scalar before loading. + * For the protection of $! to work (it is set by this routine) + * the sv slot must already be magicalized. */ -STATIC void -S_require_errno(pTHX_ GV *gv) +STATIC HV* +S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methpv,const U32 flags) { dVAR; - HV* stash = gv_stashpvn("Errno",5,FALSE); + HV* stash = gv_stashsv(namesv, 0); + + PERL_ARGS_ASSERT_REQUIRE_TIE_MOD; - if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { + if (!stash || !(gv_fetchmethod(stash, methpv))) { + SV *module = newSVsv(namesv); + char varname = *varpv; /* varpv might be clobbered by load_module, + so save it. For the moment it's always + a single char. */ dSP; - PUTBACK; ENTER; - save_scalar(gv); /* keep the value of $! */ - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvn("Errno",5), Nullsv); + if ( flags & 1 ) + save_scalar(gv); + PUSHSTACKi(PERLSI_MAGIC); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, module, NULL); + POPSTACK; 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"); + stash = gv_stashsv(namesv, 0); + if (!stash) + Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available", + varname, SVfARG(namesv)); + else if (!gv_fetchmethod(stash, methpv)) + Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" does not support method %s", + varname, SVfARG(namesv), methpv); } + SvREFCNT_dec(namesv); + return stash; } /* =for apidoc gv_stashpv -Returns a pointer to the stash for a specified package. C should -be a valid UTF-8 string and must be null-terminated. 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. Uses C to +determine the length of C, then calls C. =cut */ @@ -591,123 +861,144 @@ is not set and the package does not exist then NULL is returned. HV* Perl_gv_stashpv(pTHX_ const char *name, I32 create) { + PERL_ARGS_ASSERT_GV_STASHPV; return gv_stashpvn(name, strlen(name), create); } /* =for apidoc gv_stashpvn -Returns a pointer to the stash for a specified package. C should -be a valid UTF-8 string. The C parameter indicates the length of -the C, in bytes. 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. The C +parameter indicates the length of the C, in bytes. C is passed +to C, so if set to C then the package will be +created if it does not already exist. If the package does not exist and +C is 0 (or any other setting that does not create packages) then NULL +is returned. + =cut */ HV* -Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create) +Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 flags) { - char smallbuf[256]; + char smallbuf[128]; char *tmpbuf; HV *stash; GV *tmpgv; - if (namelen + 3 < sizeof smallbuf) + PERL_ARGS_ASSERT_GV_STASHPVN; + + if (namelen + 2 <= sizeof smallbuf) tmpbuf = smallbuf; else - New(606, tmpbuf, namelen + 3, char); + Newx(tmpbuf, namelen + 2, char); Copy(name,tmpbuf,namelen,char); tmpbuf[namelen++] = ':'; tmpbuf[namelen++] = ':'; - tmpbuf[namelen] = '\0'; - tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV); + tmpgv = gv_fetchpvn_flags(tmpbuf, namelen, flags, SVt_PVHV); if (tmpbuf != smallbuf) Safefree(tmpbuf); if (!tmpgv) - return 0; + return NULL; if (!GvHV(tmpgv)) GvHV(tmpgv) = newHV(); stash = GvHV(tmpgv); - if (!HvNAME(stash)) - HvNAME(stash) = savepv(name); + if (!HvNAME_get(stash)) + hv_name_set(stash, name, namelen, 0); 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. +Returns a pointer to the stash for a specified package. See C. =cut */ HV* -Perl_gv_stashsv(pTHX_ SV *sv, I32 create) +Perl_gv_stashsv(pTHX_ SV *sv, I32 flags) { - register char *ptr; STRLEN len; - ptr = SvPV(sv,len); - return gv_stashpvn(ptr, len, create); + const char * const ptr = SvPV_const(sv,len); + + PERL_ARGS_ASSERT_GV_STASHSV; + + return gv_stashpvn(ptr, len, flags); } GV * -Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) { - STRLEN len = strlen (nambeg); - return gv_fetchpvn_flags(nambeg, len, add, sv_type); +Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type) { + PERL_ARGS_ASSERT_GV_FETCHPV; + return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type); } GV * -Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) { +Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, const svtype sv_type) { STRLEN len; - const char *nambeg = SvPV(name, len); + const char * const nambeg = SvPV_const(name, len); + PERL_ARGS_ASSERT_GV_FETCHSV; return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type); } GV * Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, - I32 sv_type) + const svtype sv_type) { + dVAR; register const char *name = nambeg; - register GV *gv = 0; + register GV *gv = NULL; GV**gvp; I32 len; - register const char *namend; - HV *stash = 0; - const I32 add = flags & ~SVf_UTF8; - (void)full_len; + register const char *name_cursor; + HV *stash = NULL; + const I32 no_init = flags & (GV_NOADD_NOINIT | GV_NOINIT); + const I32 no_expand = flags & GV_NOEXPAND; + const I32 add = flags & ~GV_NOADD_MASK; + const char *const name_end = nambeg + full_len; + const char *const name_em1 = name_end - 1; + U32 faking_it; + + PERL_ARGS_ASSERT_GV_FETCHPVN_FLAGS; + + if (flags & GV_NOTQUAL) { + /* Caller promised that there is no stash, so we can skip the check. */ + len = full_len; + goto no_stash; + } - if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */ + if (full_len > 2 && *name == '*' && isALPHA(name[1])) { + /* accidental stringify on a GV? */ name++; + } - for (namend = name; *namend; namend++) { - if ((*namend == ':' && namend[1] == ':') - || (*namend == '\'' && namend[1])) + for (name_cursor = name; name_cursor < name_end; name_cursor++) { + if ((*name_cursor == ':' && name_cursor < name_em1 + && name_cursor[1] == ':') + || (*name_cursor == '\'' && name_cursor[1])) { if (!stash) stash = PL_defstash; if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */ - return Nullgv; + return NULL; - len = namend - name; + len = name_cursor - name; if (len > 0) { - char smallbuf[256]; + char smallbuf[128]; char *tmpbuf; - if (len + 3 < sizeof (smallbuf)) + if (len + 2 <= (I32)sizeof (smallbuf)) tmpbuf = smallbuf; else - New(601, tmpbuf, len+3, char); + Newx(tmpbuf, len+2, char); Copy(name, tmpbuf, len, char); tmpbuf[len++] = ':'; tmpbuf[len++] = ':'; - tmpbuf[len] = '\0'; gvp = (GV**)hv_fetch(stash,tmpbuf,len,add); - gv = gvp ? *gvp : Nullgv; - if (gv && gv != (GV*)&PL_sv_undef) { + gv = gvp ? *gvp : NULL; + if (gv && gv != (const GV *)&PL_sv_undef) { if (SvTYPE(gv) != SVt_PVGV) gv_init(gv, stash, tmpbuf, len, (add & GV_ADDMULTI)); else @@ -715,54 +1006,65 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } if (tmpbuf != smallbuf) Safefree(tmpbuf); - if (!gv || gv == (GV*)&PL_sv_undef) - return Nullgv; + if (!gv || gv == (const GV *)&PL_sv_undef) + return NULL; if (!(stash = GvHV(gv))) stash = GvHV(gv) = newHV(); - if (!HvNAME(stash)) - HvNAME(stash) = savepvn(nambeg, namend - nambeg); + if (!HvNAME_get(stash)) + hv_name_set(stash, nambeg, name_cursor - nambeg, 0); } - if (*namend == ':') - namend++; - namend++; - name = namend; - if (!*name) - return gv ? gv : (GV*)*hv_fetch(PL_defstash, "main::", 6, TRUE); + if (*name_cursor == ':') + name_cursor++; + name_cursor++; + name = name_cursor; + if (name == name_end) + return gv + ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE)); } } - len = namend - name; + len = name_cursor - name; /* No stash in name, so see how we can default */ if (!stash) { - if (isIDFIRST_lazy(name)) { + no_stash: + if (len && isIDFIRST_lazy(name)) { bool global = FALSE; - /* name is always \0 terminated, and initial \0 wouldn't return - true from isIDFIRST_lazy, so we know that name[1] is defined */ - switch (name[1]) { - case '\0': + switch (len) { + case 1: if (*name == '_') global = TRUE; break; - case 'N': - if (strEQ(name, "INC") || strEQ(name, "ENV")) + case 3: + if ((name[0] == 'I' && name[1] == 'N' && name[2] == 'C') + || (name[0] == 'E' && name[1] == 'N' && name[2] == 'V') + || (name[0] == 'S' && name[1] == 'I' && name[2] == 'G')) global = TRUE; break; - case 'I': - if (strEQ(name, "SIG")) + case 4: + if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' + && name[3] == 'V') + global = TRUE; + break; + case 5: + if (name[0] == 'S' && name[1] == 'T' && name[2] == 'D' + && name[3] == 'I' && name[4] == 'N') global = TRUE; break; - case 'T': - if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") || - strEQ(name, "STDERR")) + case 6: + if ((name[0] == 'S' && name[1] == 'T' && name[2] == 'D') + &&((name[3] == 'O' && name[4] == 'U' && name[5] == 'T') + ||(name[3] == 'E' && name[4] == 'R' && name[5] == 'R'))) global = TRUE; break; - case 'R': - if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT")) + case 7: + if (name[0] == 'A' && name[1] == 'R' && name[2] == 'G' + && name[3] == 'V' && name[4] == 'O' && name[5] == 'U' + && name[6] == 'T') global = TRUE; break; } @@ -781,10 +1083,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { gvp = (GV**)hv_fetch(stash,name,len,0); if (!gvp || - *gvp == (GV*)&PL_sv_undef || + *gvp == (const GV *)&PL_sv_undef || SvTYPE(*gvp) != SVt_PVGV) { - stash = 0; + stash = NULL; } else if ((sv_type == SVt_PV && !GvIMPORTED_SV(*gvp)) || (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || @@ -796,7 +1098,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, name); if (GvCVu(*gvp)) Perl_warn(aTHX_ "\t(Did you mean &%s instead?)\n", name); - stash = 0; + stash = NULL; } } } @@ -811,48 +1113,67 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (!stash) { if (add) { - register SV *err = Perl_mess(aTHX_ + SV * const 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); + GV *gv; if (USE_UTF8_IN_NAMES) SvUTF8_on(err); qerror(err); - stash = GvHV(gv_fetchpv("::", GV_ADDMULTI, SVt_PVHV)); + gv = gv_fetchpvs("::", GV_ADDMULTI, SVt_PVHV); + if(!gv) { + /* symbol table under destruction */ + return NULL; + } + stash = GvHV(gv); } else - return Nullgv; + return NULL; } if (!SvREFCNT(stash)) /* symbol table under destruction */ - return Nullgv; + return NULL; gvp = (GV**)hv_fetch(stash,name,len,add); - if (!gvp || *gvp == (GV*)&PL_sv_undef) - return Nullgv; + if (!gvp || *gvp == (const GV *)&PL_sv_undef) + return NULL; gv = *gvp; if (SvTYPE(gv) == SVt_PVGV) { if (add) { GvMULTI_on(gv); gv_init_sv(gv, sv_type); - if (*name=='!' && sv_type == SVt_PVHV && len==1) - require_errno(gv); + if (len == 1 && (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) { + if (*name == '!') + require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); + else if (*name == '-' || *name == '+') + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); + } } return gv; - } else if (add & GV_NOINIT) { + } else if (no_init) { + return gv; + } else if (no_expand && SvROK(gv)) { return gv; } - /* Adding a new symbol */ + /* Adding a new symbol. + Unless of course there was already something non-GV here, in which case + we want to behave as if there was always a GV here, containing some sort + of subroutine. + Otherwise we run the risk of creating things like GvIO, which can cause + subtle bugs. eg the one that tripped up SQL::Translator */ + + faking_it = SvOK(gv); 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); + gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type); - if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) + if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) ) GvMULTI_on(gv) ; @@ -860,6 +1181,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (len > 1) { #ifndef EBCDIC if (*name > 'V' ) { + NOOP; /* Nothing else to do. The compiler will probably turn the switch statement into a branch table. Make sure we avoid even that small overhead for @@ -867,12 +1189,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, } else #endif { - const char *name2 = name + 1; + const char * const name2 = name + 1; switch (*name) { case 'A': if (strEQ(name2, "RGV")) { IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START; } + else if (strEQ(name2, "RGVOUT")) { + GvMULTI_on(gv); + } break; case 'E': if (strnEQ(name2, "XPORT", 5)) @@ -880,32 +1205,32 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case 'I': if (strEQ(name2, "SA")) { - AV* av = GvAVn(gv); + AV* const av = GvAVn(gv); GvMULTI_on(gv); - sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0); + sv_magic(MUTABLE_SV(av), MUTABLE_SV(gv), PERL_MAGIC_isa, + NULL, 0); /* NOTE: No support for tied ISA */ if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILLp(av) == -1) { - const char *pname; - av_push(av, newSVpvn(pname = "NDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpvn(pname = "DB_File",7)); - gv_stashpvn(pname, 7, TRUE); - av_push(av, newSVpvn(pname = "GDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpvn(pname = "SDBM_File",9)); - gv_stashpvn(pname, 9, TRUE); - av_push(av, newSVpvn(pname = "ODBM_File",9)); - gv_stashpvn(pname, 9, TRUE); + av_push(av, newSVpvs("NDBM_File")); + gv_stashpvs("NDBM_File", GV_ADD); + av_push(av, newSVpvs("DB_File")); + gv_stashpvs("DB_File", GV_ADD); + av_push(av, newSVpvs("GDBM_File")); + gv_stashpvs("GDBM_File", GV_ADD); + av_push(av, newSVpvs("SDBM_File")); + gv_stashpvs("SDBM_File", GV_ADD); + av_push(av, newSVpvs("ODBM_File")); + gv_stashpvs("ODBM_File", GV_ADD); } } break; case 'O': if (strEQ(name2, "VERLOAD")) { - HV* hv = GvHVn(gv); + HV* const hv = GvHVn(gv); GvMULTI_on(gv); - hv_magic(hv, Nullgv, PERL_MAGIC_overload); + hv_magic(hv, NULL, PERL_MAGIC_overload); } break; case 'S': @@ -913,16 +1238,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, HV *hv; I32 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); + Newxz(PL_psig_ptr, SIG_SIZE, SV*); + Newxz(PL_psig_name, SIG_SIZE, SV*); + Newxz(PL_psig_pend, SIG_SIZE, int); } GvMULTI_on(gv); hv = GvHVn(gv); - hv_magic(hv, Nullgv, PERL_MAGIC_sig); + hv_magic(hv, NULL, 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); + SV * const * const 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; @@ -935,23 +1259,35 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "ERSION")) GvMULTI_on(gv); break; + case '\003': /* $^CHILD_ERROR_NATIVE */ + if (strEQ(name2, "HILD_ERROR_NATIVE")) + goto magicalize; + break; case '\005': /* $^ENCODING */ if (strEQ(name2, "NCODING")) goto magicalize; break; + case '\015': /* $^MATCH */ + if (strEQ(name2, "ATCH")) + goto magicalize; case '\017': /* $^OPEN */ if (strEQ(name2, "PEN")) goto magicalize; break; + case '\020': /* $^PREMATCH $^POSTMATCH */ + if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) + goto magicalize; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; break; case '\025': /* ${^UNICODE}, ${^UTF8LOCALE} */ - if (strEQ(name2, "NICODE")) + if (strEQ(name2, "NICODE")) goto ro_magicalize; - if (strEQ(name2, "TF8LOCALE")) + if (strEQ(name2, "TF8LOCALE")) goto ro_magicalize; + if (strEQ(name2, "TF8CACHE")) + goto magicalize; break; case '\027': /* $^WARNING_BITS */ if (strEQ(name2, "ARNING_BITS")) @@ -967,14 +1303,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, 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 */ + /* Ensures that we have an all-digit variable, ${"1foo"} fails + this test */ + /* This snippet is taken from is_gv_magical */ const char *end = name + len; while (--end > name) { - if (!isDIGIT(*end)) return gv; + if (!isDIGIT(*end)) return gv; } - goto ro_magicalize; + goto magicalize; } } } @@ -993,61 +1329,67 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, sv_type == SVt_PVIO ) { break; } PL_sawampersand = TRUE; - goto ro_magicalize; + goto magicalize; case ':': - sv_setpv(GvSV(gv),PL_chopset); + sv_setpv(GvSVn(gv),PL_chopset); goto magicalize; case '?': #ifdef COMPLEX_STATUS - (void)SvUPGRADE(GvSV(gv), SVt_PVLV); + SvUPGRADE(GvSVn(gv), SVt_PVLV); #endif goto magicalize; case '!': + GvMULTI_on(gv); + /* If %! has been used, automatically load Errno.pm. */ - /* 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); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); - if (sv_type == SVt_PVHV) - require_errno(gv); + /* magicalization must be done before require_tie_mod is called */ + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1); break; case '-': - { - AV* av = GvAVn(gv); - sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0); - SvREADONLY_on(av); - goto magicalize; + case '+': + GvMULTI_on(gv); /* no used once warnings here */ + { + AV* const av = GvAVn(gv); + SV* const avc = (*name == '+') ? MUTABLE_SV(av) : NULL; + + sv_magic(MUTABLE_SV(av), avc, PERL_MAGIC_regdata, NULL, 0); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); + if (avc) + SvREADONLY_on(GvSVn(gv)); + SvREADONLY_on(av); + + if (sv_type == SVt_PVHV || sv_type == SVt_PVGV) + require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0); + + break; } case '*': - if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "$* is no longer supported"); - break; case '#': - if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Use of $# is deprecated"); - goto magicalize; + "$%c is no longer supported", *name); + break; case '|': - sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); + sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0); goto magicalize; - case '+': - { - AV* av = GvAVn(gv); - sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0); - SvREADONLY_on(av); - /* FALL THROUGH */ - } + case '\010': /* $^H */ + { + HV *const hv = GvHVn(gv); + hv_magic(hv, NULL, PERL_MAGIC_hints); + } + goto magicalize; case '\023': /* $^S */ + ro_magicalize: + SvREADONLY_on(GvSVn(gv)); + /* FALL THROUGH */ case '1': case '2': case '3': @@ -1057,9 +1399,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '7': case '8': case '9': - ro_magicalize: - SvREADONLY_on(GvSV(gv)); - /* FALL THROUGH */ case '[': case '^': case '~': @@ -1070,7 +1409,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case ')': case '<': case '>': - case ',': case '\\': case '/': case '\001': /* $^A */ @@ -1078,7 +1416,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\004': /* $^D */ case '\005': /* $^E */ case '\006': /* $^F */ - case '\010': /* $^H */ case '\011': /* $^I, NOT \t in EBCDIC */ case '\016': /* $^N */ case '\017': /* $^O */ @@ -1086,21 +1423,21 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, case '\024': /* $^T */ case '\027': /* $^W */ magicalize: - sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len); + sv_magic(GvSVn(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, len); break; case '\014': /* $^L */ - sv_setpv(GvSV(gv),"\f"); - PL_formfeed = GvSV(gv); + sv_setpvs(GvSVn(gv),"\f"); + PL_formfeed = GvSVn(gv); break; case ';': - sv_setpv(GvSV(gv),"\034"); + sv_setpvs(GvSVn(gv),"\034"); break; case ']': { - SV *sv = GvSV(gv); + SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) - (void *)upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); GvSV(gv) = vnumify(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); @@ -1108,7 +1445,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\026': /* $^V */ { - SV * const sv = GvSV(gv); + SV * const sv = GvSVn(gv); GvSV(gv) = new_version(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); @@ -1123,126 +1460,100 @@ void Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { const char *name; + STRLEN namelen; const HV * const hv = GvSTASH(gv); + + PERL_ARGS_ASSERT_GV_FULLNAME4; + if (!hv) { SvOK_off(sv); return; } sv_setpv(sv, prefix ? prefix : ""); - - name = HvNAME(hv); - if (!name) + + name = HvNAME_get(hv); + if (name) { + namelen = HvNAMELEN_get(hv); + } else { name = "__ANON__"; - + namelen = 8; + } + if (keepmain || strNE(name, "main")) { - sv_catpv(sv,name); - sv_catpvn(sv,"::", 2); + sv_catpvn(sv,name,namelen); + sv_catpvs(sv,"::"); } sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv)); } void -Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) -{ - gv_fullname4(sv, gv, prefix, TRUE); -} - -void Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain) { - const GV *egv = GvEGV(gv); - if (!egv) - egv = gv; - gv_fullname4(sv, egv, prefix, keepmain); -} - -void -Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix) -{ - gv_efullname4(sv, gv, prefix, TRUE); -} + const GV * const egv = GvEGV(gv); -/* compatibility with versions <= 5.003. */ -void -Perl_gv_fullname(pTHX_ SV *sv, const GV *gv) -{ - gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); -} + PERL_ARGS_ASSERT_GV_EFULLNAME4; -/* compatibility with versions <= 5.003. */ -void -Perl_gv_efullname(pTHX_ SV *sv, const GV *gv) -{ - gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : ""); + gv_fullname4(sv, egv ? egv : gv, prefix, keepmain); } IO * Perl_newIO(pTHX) { - IO *io; + dVAR; GV *iogv; - - io = (IO*)NEWSV(0,0); - sv_upgrade((SV *)io,SVt_PVIO); - SvREFCNT(io) = 1; + IO * const io = MUTABLE_IO(newSV_type(SVt_PVIO)); + /* This used to read SvREFCNT(io) = 1; + It's not clear why the reference count needed an explicit reset. NWC + */ + assert (SvREFCNT(io) == 1); SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a - package name */ + /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); - iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV); + iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */ if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV); - SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv))); + iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); return io; } void -Perl_gv_check(pTHX_ HV *stash) +Perl_gv_check(pTHX_ const HV *stash) { + dVAR; register I32 i; - register GV *gv; - HV *hv; + + PERL_ARGS_ASSERT_GV_CHECK; if (!HvARRAY(stash)) return; for (i = 0; i <= (I32) HvMAX(stash); i++) { const HE *entry; for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { + register GV *gv; + HV *hv; if (HeKEY(entry)[HeKLEN(entry)-1] == ':' && - (gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv))) + (gv = MUTABLE_GV(HeVAL(entry))) && isGV(gv) && (hv = GvHV(gv))) { if (hv != PL_defstash && hv != stash) gv_check(hv); /* nested package */ } else if (isALPHA(*HeKEY(entry))) { const char *file; - gv = (GV*)HeVAL(entry); + gv = MUTABLE_GV(HeVAL(entry)); if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv)) continue; 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; - } CopLINE_set(PL_curcop, GvLINE(gv)); #ifdef USE_ITHREADS CopFILE(PL_curcop) = (char *)file; /* set for warning */ #else - CopFILEGV(PL_curcop) = gv_fetchfile(file); + CopFILEGV(PL_curcop) + = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif Perl_warner(aTHX_ packWARN(WARN_ONCE), "Name \"%s::%s\" used only once: possible typo", - HvNAME(stash), GvNAME(gv)); + HvNAME_get(stash), GvNAME(gv)); } } } @@ -1251,8 +1562,12 @@ Perl_gv_check(pTHX_ HV *stash) GV * Perl_newGVgen(pTHX_ const char *pack) { + dVAR; + + PERL_ARGS_ASSERT_NEWGVGEN; + return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++), - TRUE, SVt_PVGV); + GV_ADD, SVt_PVGV); } /* hopefully this is only called on local symbol table entries */ @@ -1260,20 +1575,19 @@ Perl_newGVgen(pTHX_ const char *pack) GP* Perl_gp_ref(pTHX_ GP *gp) { + dVAR; if (!gp) - return (GP*)NULL; + return NULL; gp->gp_refcnt++; if (gp->gp_cv) { if (gp->gp_cvgen) { - /* multi-named GPs cannot be used for method cache */ + /* If the GP they asked for a reference to contains + a method cache entry, clear it first, so that we + don't infect them with our cached entry */ SvREFCNT_dec(gp->gp_cv); - gp->gp_cv = Nullcv; + gp->gp_cv = NULL; gp->gp_cvgen = 0; } - else { - /* Adding a new name to a subroutine invalidates method cache */ - PL_sub_generation++; - } } return gp; } @@ -1281,9 +1595,10 @@ Perl_gp_ref(pTHX_ GP *gp) void Perl_gp_free(pTHX_ GV *gv) { + dVAR; GP* gp; - if (!gv || !(gp = GvGP(gv))) + if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv))) return; if (gp->gp_refcnt == 0) { if (ckWARN_d(WARN_INTERNAL)) @@ -1292,28 +1607,29 @@ Perl_gp_free(pTHX_ GV *gv) pTHX__FORMAT pTHX__VALUE); return; } - if (gp->gp_cv) { - /* Deleting the name of a subroutine invalidates method cache */ - PL_sub_generation++; - } if (--gp->gp_refcnt > 0) { if (gp->gp_egv == gv) gp->gp_egv = 0; + GvGP(gv) = 0; return; } - 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_file_hek) + unshare_hek(gp->gp_file_hek); + SvREFCNT_dec(gp->gp_sv); + SvREFCNT_dec(gp->gp_av); + /* FIXME - another reference loop GV -> symtab -> GV ? + Somehow gp->gp_hv can end up pointing at freed garbage. */ + if (gp->gp_hv && SvTYPE(gp->gp_hv) == SVt_PVHV) { + const char *hvname = HvNAME_get(gp->gp_hv); + if (PL_stashcache && hvname) + (void)hv_delete(PL_stashcache, hvname, HvNAMELEN_get(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); + SvREFCNT_dec(gp->gp_io); + SvREFCNT_dec(gp->gp_cv); + SvREFCNT_dec(gp->gp_form); Safefree(gp); GvGP(gv) = 0; @@ -1322,16 +1638,18 @@ Perl_gp_free(pTHX_ GV *gv) int Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) { - AMT *amtp = (AMT*)mg->mg_ptr; - (void)sv; + AMT * const amtp = (AMT*)mg->mg_ptr; + PERL_UNUSED_ARG(sv); + + PERL_ARGS_ASSERT_MAGIC_FREEOVRLD; 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; + CV * const cv = amtp->table[i]; + if (cv) { + SvREFCNT_dec(MUTABLE_SV(cv)); + amtp->table[i] = NULL; } } } @@ -1343,54 +1661,65 @@ Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg) bool Perl_Gv_AMupdate(pTHX_ HV *stash) { - GV* gv; - CV* cv; - MAGIC* mg=mg_find((SV*)stash, PERL_MAGIC_overload_table); - AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL; + dVAR; + MAGIC* const mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); AMT amt; + const struct mro_meta* stash_meta = HvMROMETA(stash); + U32 newgen; - if (mg && amtp->was_ok_am == PL_amagic_generation - && amtp->was_ok_sub == PL_sub_generation) - return (bool)AMT_OVERLOADED(amtp); - sv_unmagic((SV*)stash, PERL_MAGIC_overload_table); + PERL_ARGS_ASSERT_GV_AMUPDATE; - DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) ); + newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; + if (mg) { + const AMT * const amtp = (AMT*)mg->mg_ptr; + if (amtp->was_ok_am == PL_amagic_generation + && amtp->was_ok_sub == newgen) { + return (bool)AMT_OVERLOADED(amtp); + } + sv_unmagic(MUTABLE_SV(stash), PERL_MAGIC_overload_table); + } + + DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME_get(stash)) ); Zero(&amt,1,AMT); amt.was_ok_am = PL_amagic_generation; - amt.was_ok_sub = PL_sub_generation; + amt.was_ok_sub = newgen; amt.fallback = AMGfallNO; amt.flags = 0; { int filled = 0, have_ovl = 0; int i, lim = 1; - SV* sv = NULL; /* Work with "fallback" key, which we assume to be first in PL_AMG_names */ /* Try to find via inheritance. */ - gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); - if (gv) - sv = GvSV(gv); + GV *gv = gv_fetchmeth(stash, PL_AMG_names[0], 2, -1); + SV * const sv = gv ? GvSV(gv) : NULL; + CV* cv; if (!gv) lim = DESTROY_amg; /* Skip overloading entries. */ +#ifdef PERL_DONT_CREATE_GVSV + else if (!sv) { + NOOP; /* Equivalent to !SvTRUE and !SvOK */ + } +#endif else if (SvTRUE(sv)) amt.fallback=AMGfallYES; else if (SvOK(sv)) amt.fallback=AMGfallNEVER; for (i = 1; i < lim; i++) - amt.table[i] = Nullcv; + amt.table[i] = NULL; for (; i < NofAMmeth; i++) { - const char *cooky = PL_AMG_names[i]; + const char * const cooky = PL_AMG_names[i]; /* Human-readable form, for debugging: */ - const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); - const STRLEN l = strlen(cooky); + const char * const cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i)); + const STRLEN l = PL_AMG_namelens[i]; - DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n", - cp, HvNAME(stash)) ); + DEBUG_o( Perl_deb(aTHX_ "Checking overloading of \"%s\" in package \"%.256s\"\n", + cp, HvNAME_get(stash)) ); /* don't fill the cache while looking up! Creation of inheritance stubs in intermediate packages may conflict with the logic of runtime method substitution. @@ -1404,48 +1733,49 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1); cv = 0; if (gv && (cv = GvCV(gv))) { + const char *hvname; if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil") - && strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) { + && strEQ(hvname = HvNAME_get(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 = Nullgv; - - 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)), + GV *ngv = NULL; + SV *gvsv = GvSV(gv); + + DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\ + "\" for overloaded \"%s\" in package \"%.256s\"\n", + (void*)GvSV(gv), cp, hvname) ); + if (!gvsv || !SvPOK(gvsv) + || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(gvsv), FALSE))) { - /* 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'", + /* Can be an import stub (created by "can"). */ + const char * const name = (gvsv && SvPOK(gvsv)) ? SvPVX_const(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)); + name, cp, hvname); } cv = GvCV(gv = ngv); } - DEBUG_o( Perl_deb(aTHX_ "Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n", - cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))), + DEBUG_o( Perl_deb(aTHX_ "Overloading \"%s\" in package \"%.256s\" via \"%.256s::%.256s\"\n", + cp, HvNAME_get(stash), HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))) ); filled = 1; if (i < DESTROY_amg) have_ovl = 1; } else if (gv) { /* Autoloaded... */ - cv = (CV*)gv; + cv = MUTABLE_CV(gv); filled = 1; } - amt.table[i]=(CV*)SvREFCNT_inc(cv); + amt.table[i]=MUTABLE_CV(SvREFCNT_inc_simple(cv)); } if (filled) { AMT_AMAGIC_on(&amt); if (have_ovl) AMT_OVERLOADED_on(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMT)); return have_ovl; } @@ -1453,7 +1783,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) /* Here we have no table: */ /* no_table: */ AMT_AMAGIC_off(&amt); - sv_magic((SV*)stash, 0, PERL_MAGIC_overload_table, + sv_magic(MUTABLE_SV(stash), 0, PERL_MAGIC_overload_table, (char*)&amt, sizeof(AMTS)); return FALSE; } @@ -1462,38 +1792,45 @@ Perl_Gv_AMupdate(pTHX_ HV *stash) CV* Perl_gv_handler(pTHX_ HV *stash, I32 id) { + dVAR; MAGIC *mg; AMT *amtp; - CV *ret; + U32 newgen; + struct mro_meta* stash_meta; + + if (!stash || !HvNAME_get(stash)) + return NULL; + + stash_meta = HvMROMETA(stash); + newgen = PL_sub_generation + stash_meta->pkg_gen + stash_meta->cache_gen; - if (!stash || !HvNAME(stash)) - return Nullcv; - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) { do_update: Gv_AMupdate(stash); - mg = mg_find((SV*)stash, PERL_MAGIC_overload_table); + mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); } + assert(mg); amtp = (AMT*)mg->mg_ptr; if ( amtp->was_ok_am != PL_amagic_generation - || amtp->was_ok_sub != PL_sub_generation ) + || amtp->was_ok_sub != newgen ) goto do_update; if (AMT_AMAGIC(amtp)) { - ret = amtp->table[id]; + CV * const 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, PL_AMG_names[id]); + GV * const gv = gv_fetchmethod(stash, PL_AMG_names[id]); if (gv && GvCV(gv)) return GvCV(gv); } return ret; } - - return Nullcv; + + return NULL; } @@ -1505,25 +1842,30 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CV *cv=NULL; CV **cvp=NULL, **ocvp=NULL; 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; + int off = 0, off1, lr = 0, notfound = 0; + int postpr = 0, force_cpy = 0; + int assign = AMGf_assign & flags; + const int assignshift = assign ? 1 : 0; #ifdef DEBUGGING int fl=0; #endif HV* stash=NULL; + + PERL_ARGS_ASSERT_AMAGIC_CALL; + if (!(AMGf_noleft & flags) && SvAMAGIC(left) && (stash = SvSTASH(SvRV(left))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table - : (CV **) NULL)) + : NULL)) && ((cv = cvp[off=method+assignshift]) || (assign && amtp->fallback > AMGfallNEVER && /* fallback to * usual method */ ( #ifdef DEBUGGING fl = 1, -#endif +#endif cv = cvp[off=method])))) { lr = -1; /* Call method for left argument */ } else { @@ -1556,27 +1898,33 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case string_amg: (void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])); break; - case not_amg: - (void)((cv = cvp[off=bool__amg]) - || (cv = cvp[off=numer_amg]) - || (cv = cvp[off=string_amg])); - postpr = 1; - break; + case not_amg: + (void)((cv = cvp[off=bool__amg]) + || (cv = cvp[off=numer_amg]) + || (cv = cvp[off=string_amg])); + postpr = 1; + break; case copy_amg: { /* * SV* ref causes confusion with the interpreter variable of * the same name */ - SV* tmpRef=SvRV(left); + SV* const tmpRef=SvRV(left); if (!SvROK(tmpRef) && SvTYPE(tmpRef) <= SVt_PVMG) { /* * Just to be extra cautious. Maybe in some * additional cases sv_setsv is safe, too. */ - SV* newref = newSVsv(tmpRef); + SV* const newref = newSVsv(tmpRef); SvOBJECT_on(newref); - SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef))); + /* As a bit of a source compatibility hack, SvAMAGIC() and + friends dereference an RV, to behave the same was as when + overloading was stored on the reference, not the referant. + Hence we can't use SvAMAGIC_on() + */ + SvFLAGS(newref) |= SVf_AMAGIC; + SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef)))); return newref; } } @@ -1584,13 +1932,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) case abs_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)); + SV* const nullsv=sv_2mortal(newSViv(0)); if (off1==lt_amg) { - SV* lessp = amagic_call(left,nullsv, + SV* const lessp = amagic_call(left,nullsv, lt_amg,AMGf_noright); logic = SvTRUE(lessp); } else { - SV* lessp = amagic_call(left,nullsv, + SV* const lessp = amagic_call(left,nullsv, ncmp_amg,AMGf_noright); logic = (SvNV(lessp) < 0); } @@ -1631,10 +1979,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) if (!cv) goto not_found; } else if (!(AMGf_noright & flags) && SvAMAGIC(right) && (stash = SvSTASH(SvRV(right))) - && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table)) + && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table)) && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) ? (amtp = (AMT*)mg->mg_ptr)->table - : (CV **) NULL)) + : NULL)) && (cv = cvp[off=method])) { /* Method for right * argument found */ lr=1; @@ -1673,6 +2021,19 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } else { not_found: /* No method found, either report or croak */ switch (method) { + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: + postpr = 0; break; case to_sv_amg: case to_av_amg: case to_hv_amg: @@ -1686,18 +2047,21 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) notfound = 1; lr = -1; } else if (cvp && (cv=cvp[nomethod_amg])) { notfound = 1; lr = 1; + } else if ((amtp && amtp->fallback >= AMGfallYES) && !DEBUG_o_TEST) { + /* Skip generating the "no method found" message. */ + return NULL; } else { SV *msg; if (off==-1) off=method; msg = sv_2mortal(Perl_newSVpvf(aTHX_ - "Operation `%s': no method found,%sargument %s%s%s%s", + "Operation \"%s\": no method found,%sargument %s%s%s%s", AMG_id2name(method + assignshift), (flags & AMGf_unary ? " " : "\n\tleft "), SvAMAGIC(left)? "in overloaded package ": "has no overloaded magic", SvAMAGIC(left)? - HvNAME(SvSTASH(SvRV(left))): + HvNAME_get(SvSTASH(SvRV(left))): "", SvAMAGIC(right)? ",\n\tright argument in overloaded package ": @@ -1705,12 +2069,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) ? "" : ",\n\tright argument has no overloaded magic"), SvAMAGIC(right)? - HvNAME(SvSTASH(SvRV(right))): + HvNAME_get(SvSTASH(SvRV(right))): "")); if (amtp && amtp->fallback >= AMGfallYES) { - DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX(msg)) ); + DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) ); } else { - Perl_croak(aTHX_ "%"SVf, msg); + Perl_croak(aTHX_ "%"SVf, SVfARG(msg)); } return NULL; } @@ -1720,17 +2084,17 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ - "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n", + "Overloaded operator \"%s\"%s%s%s:\n\tmethod%s found%s in package %s%s\n", AMG_id2name(off), method+assignshift==off? "" : - " (initially `", + " (initially \"", method+assignshift==off? "" : AMG_id2name(method+assignshift), - method+assignshift==off? "" : "')", + method+assignshift==off? "" : "\")", flags & AMGf_unary? "" : lr==1 ? " for right argument": " for left argument", flags & AMGf_unary? " for argument" : "", - stash ? HvNAME(stash) : "null", + stash ? HvNAME_get(stash) : "null", fl? ",\n\tassignment variant used": "") ); } #endif @@ -1764,12 +2128,12 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) dSP; BINOP myop; SV* res; - bool oldcatch = CATCH_GET; + const bool oldcatch = CATCH_GET; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; PUSHSTACKi(PERLSI_OVERLOAD); @@ -1786,12 +2150,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(lr>0? left: right); PUSHs( lr > 0 ? &PL_sv_yes : ( assign ? &PL_sv_undef : &PL_sv_no )); if (notfound) { - PUSHs( sv_2mortal(newSVpv(AMG_id2name(method + assignshift),0))); + PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), + AMG_id2namelen(method + assignshift), SVs_TEMP)); } - PUSHs((SV*)cv); + PUSHs(MUTABLE_SV(cv)); PUTBACK; - if ((PL_op = Perl_pp_entersub(aTHX))) + if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; @@ -1802,7 +2167,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) CATCH_SET(oldcatch); if (postpr) { - int ans=0; + int ans; switch (method) { case le_amg: case sle_amg: @@ -1827,6 +2192,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) SvSetSV(left,res); return left; case not_amg: ans=!SvTRUE(res); break; + default: + ans=0; break; } return boolSV(ans); } else if (method==copy_amg) { @@ -1843,22 +2210,6 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) /* =for apidoc is_gv_magical_sv -Returns C if given the name of a magical GV. Calls is_gv_magical. - -=cut -*/ - -bool -Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags) -{ - STRLEN len; - const char *temp = SvPV(name, len); - return is_gv_magical(temp, len, flags); -} - -/* -=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 @@ -1873,15 +2224,21 @@ pointers returned by SvPV. =cut */ + bool -Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) +Perl_is_gv_magical_sv(pTHX_ SV *const name_sv, U32 flags) { - (void)flags; + STRLEN len; + const char *const name = SvPV_const(name_sv, len); + + PERL_UNUSED_ARG(flags); + PERL_ARGS_ASSERT_IS_GV_MAGICAL_SV; + if (len > 1) { - const char *name1 = name + 1; + const char * const name1 = name + 1; switch (*name) { case 'I': - if (len == 3 && name1[1] == 'S' && name[2] == 'A') + if (len == 3 && name[1] == 'S' && name[2] == 'A') goto yes; break; case 'O': @@ -1906,7 +2263,7 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case '\025': /* ${^UNICODE} */ if (strEQ(name1, "NICODE")) goto yes; - if (strEQ(name1, "TF8LOCALE")) + if (strEQ(name1, "TF8LOCALE")) goto yes; break; case '\027': /* ${^WARNING_BITS} */ @@ -1953,7 +2310,6 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) case ')': case '<': case '>': - case ',': case '\\': case '/': case '|': @@ -1992,3 +2348,33 @@ Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags) } return FALSE; } + +void +Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags) +{ + dVAR; + U32 hash; + + PERL_ARGS_ASSERT_GV_NAME_SET; + PERL_UNUSED_ARG(flags); + + if (len > I32_MAX) + Perl_croak(aTHX_ "panic: gv name too long (%"UVuf")", (UV) len); + + if (!(flags & GV_ADD) && GvNAME_HEK(gv)) { + unshare_hek(GvNAME_HEK(gv)); + } + + PERL_HASH(hash, name, len); + GvNAME_HEK(gv) = share_hek(name, len, hash); +} + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */