X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c22420654592c6c91357fd0422495dbfa76ae7c7..f828ccba708aa823170a00f5a5fb04a26c9283af:/gv.c

diff --git a/gv.c b/gv.c
index a63b976..a61c34f 100644
--- a/gv.c
+++ b/gv.c
@@ -37,6 +37,7 @@ Perl stores its global variables.
 #include "perl.h"
 #include "overload.c"
 #include "keywords.h"
+#include "feature.h"
 
 static const char S_autoload[] = "AUTOLOAD";
 static const STRLEN S_autolen = sizeof(S_autoload)-1;
@@ -61,12 +62,12 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 	     */
 	    what = OP_IS_DIRHOP(PL_op->op_type) ?
 		"dirhandle" : "filehandle";
-	    /* diag_listed_as: Bad symbol for filehandle */
 	} else if (type == SVt_PVHV) {
 	    what = "hash";
 	} else {
 	    what = type == SVt_PVAV ? "array" : "scalar";
 	}
+	/* diag_listed_as: Bad symbol for filehandle */
 	Perl_croak(aTHX_ "Bad symbol for %s", what);
     }
 
@@ -316,8 +317,11 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     dVAR;
     const U32 old_type = SvTYPE(gv);
     const bool doproto = old_type > SVt_NULL;
-    char * const proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+    char * const proto = (doproto && SvPOK(gv))
+	? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))
+	: NULL;
     const STRLEN protolen = proto ? SvCUR(gv) : 0;
+    const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
     const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 
@@ -368,20 +372,12 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
 	CV *cv;
 	ENTER;
 	if (has_constant) {
-	    char *name0 = NULL;
-	    if (name[len])
-		/* newCONSTSUB doesn't take a len arg, so make sure we
-		 * give it a \0-terminated string */
-		name0 = savepvn(name,len);
-
 	    /* newCONSTSUB takes ownership of the reference from us.  */
-	    cv = newCONSTSUB(stash, (name0 ? name0 : name), has_constant);
+	    cv = newCONSTSUB_flags(stash, name, len, flags, has_constant);
 	    /* In case op.c:S_process_special_blocks stole it: */
 	    if (!GvCV(gv))
 		GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(cv));
 	    assert(GvCV(gv) == cv); /* newCONSTSUB should have set this */
-	    if (name0)
-		Safefree(name0);
 	    /* 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.  */
@@ -401,6 +397,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
 	if (proto) {
 	    sv_usepvn_flags(MUTABLE_SV(cv), proto, protolen,
 			    SV_HAS_TRAILING_NUL);
+            if ( proto_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
 	}
     }
 }
@@ -440,26 +437,21 @@ static void core_xsub(pTHX_ CV* cv);
 
 static GV *
 S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
-                          const char * const name, const STRLEN len,
-                          const char * const fullname, STRLEN const fullen)
+                          const char * const name, const STRLEN len)
 {
     const int code = keyword(name, len, 1);
     static const char file[] = __FILE__;
-    CV *cv, *oldcompcv;
+    CV *cv, *oldcompcv = NULL;
     int opnum = 0;
     SV *opnumsv;
     bool ampable = TRUE; /* &{}-able */
-    COP *oldcurcop;
-    yy_parser *oldparser;
-    I32 oldsavestack_ix;
+    COP *oldcurcop = NULL;
+    yy_parser *oldparser = NULL;
+    I32 oldsavestack_ix = 0;
 
     assert(gv || stash);
     assert(name);
-    assert(stash || fullname);
 
-    if (!fullname && !HvENAME(stash)) return NULL; /* pathological case
-                                                     that would require
-                                                    inlining newATTRSUB */
     if (code >= 0) return NULL; /* not overridable */
     switch (-code) {
      /* no support for \&CORE::infix;
@@ -490,6 +482,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
 	gv = (GV *)newSV(0);
 	gv_init(gv, stash, name, len, TRUE);
     }
+    GvMULTI_on(gv);
     if (ampable) {
 	ENTER;
 	oldcurcop = PL_curcop;
@@ -520,26 +513,20 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
            it this order as we need an op number before calling
            new ATTRSUB. */
     (void)core_prototype((SV *)cv, name, code, &opnum);
-    if (stash && (fullname || !fullen))
+    if (stash)
 	(void)hv_store(stash,name,len,(SV *)gv,0);
     if (ampable) {
-	SV *tmpstr;
 	CvLVALUE_on(cv);
-	if (!fullname) {
-	    tmpstr = newSVhek(HvENAME_HEK(stash));
-	    sv_catpvs(tmpstr, "::");
-	    sv_catpvn(tmpstr,name,len);
-	}
-	else tmpstr = newSVpvn_share(fullname,fullen,0);
-	newATTRSUB(oldsavestack_ix,
-	           newSVOP(OP_CONST, 0, tmpstr),
+	newATTRSUB_flags(
+		   oldsavestack_ix, (OP *)gv,
 	           NULL,NULL,
 	           coresub_op(
 	             opnum
 	               ? newSVuv((UV)opnum)
 	               : newSVpvn(name,len),
 	             code, opnum
-	           )
+	           ),
+	           1
 	);
 	assert(GvCV(gv) == cv);
 	if (opnum != OP_VEC && opnum != OP_SUBSTR)
@@ -665,7 +652,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     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);
+    gvp = (GV**)hv_fetch(stash, name, is_utf8 ? -(I32)len : (I32)len, create);
     if(gvp) {
         topgv = *gvp;
       have_gv:
@@ -691,7 +678,7 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
         }
 	else if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4
               && strnEQ(hvname, "CORE", 4)
-              && S_maybe_add_coresub(aTHX_ stash,topgv,name,len,0,1))
+              && S_maybe_add_coresub(aTHX_ NULL,topgv,name,len))
 	    goto have_gv;
     }
 
@@ -699,7 +686,8 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
     if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
         HV* basestash;
         packlen -= 7;
-        basestash = gv_stashpvn(hvname, packlen, GV_ADD);
+        basestash = gv_stashpvn(hvname, packlen,
+                                GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0));
         linear_av = mro_get_linear_isa(basestash);
     }
     else {
@@ -714,20 +702,22 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level,
         cstash = gv_stashsv(linear_sv, 0);
 
         if (!cstash) {
-	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
-			   SVfARG(linear_sv), hvname);
+	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+                           "Can't locate package %"SVf" for @%"HEKf"::ISA",
+			   SVfARG(linear_sv),
+                           HEKfARG(HvNAME_HEK(stash)));
             continue;
         }
 
         assert(cstash);
 
-        gvp = (GV**)hv_fetch(cstash, name, len, 0);
+        gvp = (GV**)hv_fetch(cstash, name, is_utf8 ? -(I32)len : (I32)len, 0);
         if (!gvp) {
             if (len > 1 && HvNAMELEN_get(cstash) == 4) {
                 const char *hvname = HvNAME(cstash); assert(hvname);
                 if (strnEQ(hvname, "CORE", 4)
                  && (candidate =
-                      S_maybe_add_coresub(aTHX_ cstash,NULL,name,len,0,0)
+                      S_maybe_add_coresub(aTHX_ cstash,NULL,name,len)
                     ))
                     goto have_candidate;
             }
@@ -839,7 +829,7 @@ Currently, the only significant value for C<flags> is SVf_UTF8.
 GV *
 Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, U32 flags)
 {
-    GV *gv = gv_fetchmeth_pvn(stash, name, len, level, 0);
+    GV *gv = gv_fetchmeth_pvn(stash, name, len, level, flags);
 
     PERL_ARGS_ASSERT_GV_FETCHMETH_PVN_AUTOLOAD;
 
@@ -859,7 +849,8 @@ Perl_gv_fetchmeth_pvn_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I3
 	/* Have an autoload */
 	if (level < 0)	/* Cannot do without a stub */
 	    gv_fetchmeth_pvn(stash, name, len, 0, flags);
-	gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+	gvp = (GV**)hv_fetch(stash, name,
+                        (flags & SVf_UTF8) ? -(I32)len : (I32)len, (level >= 0));
 	if (!gvp)
 	    return NULL;
 	return *gvp;
@@ -905,21 +896,24 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
 
     PERL_ARGS_ASSERT_GV_GET_SUPER_PKG;
 
-    stash = gv_stashpvn(name, namelen, 0);
+    stash = gv_stashpvn(name, namelen, flags);
     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);
+    stash = gv_stashpvn(name, namelen, GV_ADD | flags);
     gvp = (GV**)hv_fetchs(stash, "ISA", TRUE);
     gv = *gvp;
-    gv_init_pvn(gv, stash, "ISA", 3, GV_ADDMULTI|(flags & SVf_UTF8));
+    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));
+    av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
+                                     strlen(CopSTASHPV(PL_curcop)),
+                                     CopSTASH_flags(PL_curcop)
+                                    ));
 #else
     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
 			       ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL));
@@ -969,6 +963,7 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
     SV *const error_report = MUTABLE_SV(stash);
     const U32 autoload = flags & GV_AUTOLOAD;
     const U32 do_croak = flags & GV_CROAK;
+    const U32 is_utf8  = flags & SVf_UTF8;
 
     PERL_ARGS_ASSERT_GV_FETCHMETHOD_PVN_FLAGS;
 
@@ -993,8 +988,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
     if (nsplit) {
 	if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
 	    /* ->SUPER::method should really be looked up in original stash */
-	    SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
-						  CopSTASHPV(PL_curcop)));
+	    SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_
+		     "%"HEKf"::SUPER",
+		      HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop)))
+	    ));
 	    /* __PACKAGE__::SUPER stash should be autovivified */
 	    stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr));
 	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
@@ -1002,24 +999,26 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
 	}
 	else {
             /* don't autovifify if ->NoSuchStash::method */
-            stash = gv_stashpvn(origname, nsplit - origname, 0);
+            stash = gv_stashpvn(origname, nsplit - origname, is_utf8);
 
 	    /* 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, 0))
+		gv_stashpvn(origname, nsplit - origname - 7, is_utf8))
 	      stash = gv_get_super_pkg(origname, nsplit - origname, flags);
 	}
 	ostash = stash;
     }
 
-    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
+    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
     if (!gv) {
 	if (strEQ(name,"import") || strEQ(name,"unimport"))
 	    gv = MUTABLE_GV(&PL_sv_yes);
 	else if (autoload)
-	    gv = gv_autoload4(ostash, name, nend - name, TRUE);
+	    gv = gv_autoload_pvn(
+		ostash, name, nend - name, GV_AUTOLOAD_ISMETHOD|flags
+	    );
 	if (!gv && do_croak) {
 	    /* Right now this is exclusively for the benefit of S_method_common
 	       in pp_hot.c  */
@@ -1034,29 +1033,33 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
 				       HV_FETCH_ISEXISTS, NULL, 0)
 		) {
 		    require_pv("IO/File.pm");
-		    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, 0);
+		    gv = gv_fetchmeth_pvn(stash, name, nend - name, 0, flags);
 		    if (gv)
 			return gv;
 		}
 		Perl_croak(aTHX_
-			   "Can't locate object method \"%s\" via package \"%.*s\"",
-			   name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
+			   "Can't locate object method \"%"SVf
+			   "\" via package \"%"HEKf"\"",
+			            SVfARG(newSVpvn_flags(name, nend - name,
+                                           SVs_TEMP | is_utf8)),
+                                    HEKfARG(HvNAME_HEK(stash)));
 	    }
 	    else {
-		STRLEN packlen;
-		const char *packname;
+                SV* packnamesv;
 
 		if (nsplit) {
-		    packlen = nsplit - origname;
-		    packname = origname;
+		    packnamesv = newSVpvn_flags(origname, nsplit - origname,
+                                                    SVs_TEMP | is_utf8);
 		} else {
-		    packname = SvPV_const(error_report, packlen);
+		    packnamesv = sv_2mortal(newSVsv(error_report));
 		}
 
 		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);
+			   "Can't locate object method \"%"SVf"\" via package \"%"SVf"\""
+			   " (perhaps you forgot to load \"%"SVf"\"?)",
+			   SVfARG(newSVpvn_flags(name, nend - name,
+                                SVs_TEMP | is_utf8)),
+                           SVfARG(packnamesv), SVfARG(packnamesv));
 	    }
 	}
     }
@@ -1073,8 +1076,10 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le
 		if (GvCV(stubgv) != cv)		/* orphaned import */
 		    stubgv = gv;
 	    }
-	    autogv = gv_autoload4(GvSTASH(stubgv),
-				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+            autogv = gv_autoload_pvn(GvSTASH(stubgv),
+                                  GvNAME(stubgv), GvNAMELEN(stubgv),
+                                  GV_AUTOLOAD_ISMETHOD
+                                   | (GvNAMEUTF8(stubgv) ? SVf_UTF8 : 0));
 	    if (autogv)
 		gv = autogv;
 	}
@@ -1111,8 +1116,8 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
     HV* varstash;
     GV* vargv;
     SV* varsv;
-    const char *packname = "";
-    STRLEN packname_len = 0;
+    SV *packname = NULL;
+    U32 is_utf8 = flags & SVf_UTF8 ? SVf_UTF8 : 0;
 
     PERL_ARGS_ASSERT_GV_AUTOLOAD_PVN;
 
@@ -1120,15 +1125,16 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
 	return NULL;
     if (stash) {
 	if (SvTYPE(stash) < SVt_PVHV) {
-	    packname = SvPV_const(MUTABLE_SV(stash), packname_len);
+            STRLEN packname_len = 0;
+            const char * const packname_ptr = SvPV_const(MUTABLE_SV(stash), packname_len);
+            packname = newSVpvn_flags(packname_ptr, packname_len,
+                                      SVs_TEMP | SvUTF8(stash));
 	    stash = NULL;
 	}
-	else {
-	    packname = HvNAME_get(stash);
-	    packname_len = HvNAMELEN_get(stash);
-	}
+	else
+	    packname = sv_2mortal(newSVhek(HvNAME_HEK(stash)));
     }
-    if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, 0)))
+    if (!(gv = gv_fetchmeth_pvn(stash, S_autoload, S_autolen, FALSE, is_utf8)))
 	return NULL;
     cv = GvCV(gv);
 
@@ -1143,19 +1149,61 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
      && (GvCVGEN(gv) || GvSTASH(gv) != stash)
     )
 	Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
-			 "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
-			 packname, (int)len, name);
+			 "Use of inherited AUTOLOAD for non-method %"SVf"::%"SVf"() is deprecated",
+			 SVfARG(packname),
+                         SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
 
     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 '::',
-         * pass along the same data via some unused fields in the CV
+        /* Instead of forcing the XSUB do another lookup for $AUTOLOAD
+         * and split that value on the last '::', pass along the same data
+         * via the SvPVX field in the CV, and the stash in CvSTASH.
+         *
+         * Due to an unfortunate accident of history, the SvPVX field
+         * serves two purposes.  It is also used for the subroutine's pro-
+         * type.  Since SvPVX has been documented as returning the sub name
+         * for a long time, but not as returning the prototype, we have
+         * to preserve the SvPVX AUTOLOAD behaviour and put the prototype
+         * elsewhere.
+         *
+         * We put the prototype in the same allocated buffer, but after
+         * the sub name.  The SvPOK flag indicates the presence of a proto-
+         * type.  The CvAUTOLOAD flag indicates the presence of a sub name.
+         * If both flags are on, then SvLEN is used to indicate the end of
+         * the prototype (artificially lower than what is actually allo-
+         * cated), at the risk of having to reallocate a few bytes unneces-
+         * sarily--but that should happen very rarely, if ever.
+         *
+         * We use SvUTF8 for both prototypes and sub names, so if one is
+         * UTF8, the other must be upgraded.
          */
 	CvSTASH_set(cv, stash);
-        SvPV_set(cv, (char *)name); /* cast to lose constness warning */
-        SvCUR_set(cv, len);
-        return gv;
+	if (SvPOK(cv)) { /* Ouch! */
+	    SV *tmpsv = newSVpvn_flags(name, len, is_utf8);
+	    STRLEN ulen;
+	    const char *proto = CvPROTO(cv);
+	    assert(proto);
+	    if (SvUTF8(cv))
+		sv_utf8_upgrade_flags_grow(tmpsv, 0, CvPROTOLEN(cv) + 2);
+	    ulen = SvCUR(tmpsv);
+	    SvCUR(tmpsv)++; /* include null in string */
+	    sv_catpvn_flags(
+		tmpsv, proto, CvPROTOLEN(cv), SV_CATBYTES*!SvUTF8(cv)
+	    );
+	    SvTEMP_on(tmpsv); /* Allow theft */
+	    sv_setsv_nomg((SV *)cv, tmpsv);
+	    SvTEMP_off(tmpsv);
+	    SvREFCNT_dec(tmpsv);
+	    SvLEN(cv) = SvCUR(cv) + 1;
+	    SvCUR(cv) = ulen;
+	}
+	else {
+	  sv_setpvn((SV *)cv, name, len);
+	  SvPOK_off(cv);
+	  if (is_utf8)
+            SvUTF8_on(cv);
+	  else SvUTF8_off(cv);
+	}
+	CvAUTOLOAD_on(cv);
     }
 
     /*
@@ -1176,11 +1224,16 @@ Perl_gv_autoload_pvn(pTHX_ HV *stash, const char *name, STRLEN len, U32 flags)
     }
     LEAVE;
     varsv = GvSVn(vargv);
-    sv_setpvn(varsv, packname, packname_len);
+    sv_setsv(varsv, packname);
     sv_catpvs(varsv, "::");
     /* Ensure SvSETMAGIC() is called if necessary. In particular, to clear
        tainting if $FOO::AUTOLOAD was previously tainted, but is not now.  */
-    sv_catpvn_mg(varsv, name, len);
+    sv_catpvn_flags(
+	varsv, name, len,
+	SV_SMAGIC|(is_utf8 ? SV_CATUTF8 : SV_CATBYTES)
+    );
+    if (is_utf8)
+        SvUTF8_on(varsv);
     return gv;
 }
 
@@ -1205,11 +1258,12 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp
 
     PERL_ARGS_ASSERT_REQUIRE_TIE_MOD;
 
-    if (!stash || !(gv_fetchmethod(stash, methpv))) {
+    if (!stash || !(gv_fetchmethod_autoload(stash, methpv, FALSE))) {
 	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. */
+	const char type = varname == '[' ? '$' : '%';
 	dSP;
 	ENTER;
 	if ( flags & 1 )
@@ -1221,11 +1275,11 @@ S_require_tie_mod(pTHX_ GV *gv, const char *varpv, SV* namesv, const char *methp
 	SPAGAIN;
 	stash = gv_stashsv(namesv, 0);
 	if (!stash)
-	    Perl_croak(aTHX_ "panic: Can't use %%%c because %"SVf" is not available",
-		    varname, SVfARG(namesv));
+	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" is not available",
+		    type, 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);
+	    Perl_croak(aTHX_ "panic: Can't use %c%c because %"SVf" does not support method %s",
+		    type, varname, SVfARG(namesv), methpv);
     }
     SvREFCNT_dec(namesv);
     return stash;
@@ -1387,7 +1441,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	goto no_stash;
     }
 
-    if (full_len > 2 && *name == '*' && isALPHA(name[1])) {
+    if (full_len > 2 && *name == '*' && isIDFIRST_lazy_if(name + 1, is_utf8)) {
 	/* accidental stringify on a GV? */
 	name++;
     }
@@ -1526,17 +1580,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 			     (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) ||
 			     (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) )
 		    {
+                        SV* namesv = newSVpvn_flags(name, len, SVs_TEMP | is_utf8);
 			/* diag_listed_as: Variable "%s" is not imported%s */
 			Perl_ck_warner_d(
 			    aTHX_ packWARN(WARN_MISC),
-			    "Variable \"%c%s\" is not imported",
+			    "Variable \"%c%"SVf"\" is not imported",
 			    sv_type == SVt_PVAV ? '@' :
 			    sv_type == SVt_PVHV ? '%' : '$',
-			    name);
+			    SVfARG(namesv));
 			if (GvCVu(*gvp))
 			    Perl_ck_warner_d(
 				aTHX_ packWARN(WARN_MISC),
-				"\t(Did you mean &%s instead?)\n", name
+				"\t(Did you mean &%"SVf" instead?)\n", SVfARG(namesv)
 			    );
 			stash = NULL;
 		    }
@@ -1554,11 +1609,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     if (!stash) {
 	if (add) {
 	    SV * const err = Perl_mess(aTHX_
-		 "Global symbol \"%s%s\" requires explicit package name",
+		 "Global symbol \"%s%"SVf"\" requires explicit package name",
 		 (sv_type == SVt_PV ? "$"
 		  : sv_type == SVt_PVAV ? "@"
 		  : sv_type == SVt_PVHV ? "%"
-		  : ""), name);
+		  : ""), SVfARG(newSVpvn_flags(name, len, SVs_TEMP | is_utf8)));
 	    GV *gv;
 	    if (USE_UTF8_IN_NAMES)
 		SvUTF8_on(err);
@@ -1590,12 +1645,21 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	if (add) {
 	    GvMULTI_on(gv);
 	    gv_init_svtype(gv, sv_type);
-	    if (len == 1 && stash == PL_defstash
-		&& (sv_type == SVt_PVHV || sv_type == SVt_PVGV)) {
+	    if (len == 1 && stash == PL_defstash) {
+	      if (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);
+	      }
+	      if (sv_type==SVt_PV || sv_type==SVt_PVGV) {
+	       if (*name == '[')
+		require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+	       else if (*name == '&' || *name == '`' || *name == '\'') {
+		PL_sawampersand = TRUE;
+		(void)GvSVn(gv);
+	       }
+	      }
 	    }
 	    else if (len == 3 && sv_type == SVt_PVAV
 	          && strnEQ(name, "ISA", 3)
@@ -1621,11 +1685,12 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
     faking_it = SvOK(gv);
 
     if (add & GV_ADDWARN)
-	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
+	Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %"SVf" unexpectedly",
+                SVfARG(newSVpvn_flags(nambeg, name_end-nambeg, SVs_TEMP | is_utf8 )));
     gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8);
 
-    if (isALPHA(name[0]) && ! (isLEXWARN_on ? ckWARN(WARN_ONCE)
-			                    : (PL_dowarn & G_WARN_ON ) ) )
+    if ( isIDFIRST_lazy_if(name, is_utf8)
+                && ! (isLEXWARN_on ? ckWARN(WARN_ONCE) : (PL_dowarn & G_WARN_ON ) ) )
         GvMULTI_on(gv) ;
 
     /* set up magic where warranted */
@@ -1661,11 +1726,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	if (len > 1 /* shortest is uc */ && HvNAMELEN_get(stash) == 4) {
 	  /* Avoid null warning: */
 	  const char * const stashname = HvNAME(stash); assert(stashname);
-	  if (strnEQ(stashname, "CORE", 4)
-	   && S_maybe_add_coresub(aTHX_
-	        addmg ? stash : 0, gv, name, len, nambeg, full_len
-	      ))
-	    addmg = 0;
+	  if (strnEQ(stashname, "CORE", 4))
+	    S_maybe_add_coresub(aTHX_ 0, gv, name, len);
 	}
     }
     else if (len > 1) {
@@ -1805,14 +1867,13 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '&':		/* $& */
 	case '`':		/* $` */
 	case '\'':		/* $' */
-	    if (
+	    if (!(
 		sv_type == SVt_PVAV ||
 		sv_type == SVt_PVHV ||
 		sv_type == SVt_PVCV ||
 		sv_type == SVt_PVFM ||
 		sv_type == SVt_PVIO
-		) { break; }
-	    PL_sawampersand = TRUE;
+		)) { PL_sawampersand = TRUE; }
 	    goto magicalize;
 
 	case ':':		/* $: */
@@ -1833,7 +1894,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
             /* magicalization must be done before require_tie_mod is called */
 	    if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+	    {
+		if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+		addmg = 0;
 		require_tie_mod(gv, "!", newSVpvs("Errno"), "TIEHASH", 1);
+	    }
 
 	    break;
 	case '-':		/* $- */
@@ -1850,13 +1915,18 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
+	    {
+		if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+		addmg = 0;
                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
+	    }
 
             break;
 	}
 	case '*':		/* $* */
 	case '#':		/* $# */
 	    if (sv_type == SVt_PV)
+		/* diag_listed_as: $* is no longer supported */
 		Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 				 "$%c is no longer supported", *name);
 	    break;
@@ -1870,6 +1940,15 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 		hv_magic(hv, NULL, PERL_MAGIC_hints);
 	    }
 	    goto magicalize;
+	case '[':		/* $[ */
+	    if ((sv_type == SVt_PV || sv_type == SVt_PVGV)
+	     && FEATURE_ARYBASE_IS_ENABLED) {
+		if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+		require_tie_mod(gv,name,newSVpvs("arybase"),"FETCH",0);
+		addmg = 0;
+	    }
+	    else goto magicalize;
+            break;
 	case '\023':	/* $^S */
 	ro_magicalize:
 	    SvREADONLY_on(GvSVn(gv));
@@ -1884,7 +1963,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 	case '7':		/* $7 */
 	case '8':		/* $8 */
 	case '9':		/* $9 */
-	case '[':		/* $[ */
 	case '^':		/* $^ */
 	case '~':		/* $~ */
 	case '=':		/* $= */
@@ -1954,25 +2032,21 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 void
 Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    SV *name;
+    const char *name;
     const HV * const hv = GvSTASH(gv);
 
     PERL_ARGS_ASSERT_GV_FULLNAME4;
 
-    if (!hv) {
-	SvOK_off(sv);
-	return;
-    }
     sv_setpv(sv, prefix ? prefix : "");
 
-    name = HvNAME_get(hv)
-            ? sv_2mortal(newSVhek(HvNAME_HEK(hv)))
-            : newSVpvn_flags( "__ANON__", 8, SVs_TEMP );
-
-    if (keepmain || strnNE(SvPV_nolen(name), "main", SvCUR(name))) {
-	sv_catsv(sv,name);
+    if (hv && (name = HvNAME(hv))) {
+      const STRLEN len = HvNAMELEN(hv);
+      if (keepmain || strnNE(name, "main", len)) {
+	sv_catpvn_flags(sv,name,len,HvNAMEUTF8(hv)?SV_CATUTF8:SV_CATBYTES);
 	sv_catpvs(sv,"::");
+      }
     }
+    else sv_catpvs(sv,"__ANON__::");
     sv_catsv(sv,sv_2mortal(newSVhek(GvNAME_HEK(gv))));
 }
 
@@ -2007,7 +2081,8 @@ Perl_gv_check(pTHX_ const HV *stash)
 		if (hv != PL_defstash && hv != stash)
 		     gv_check(hv);              /* nested package */
 	    }
-	    else if (isALPHA(*HeKEY(entry))) {
+            else if ( *HeKEY(entry) != '_'
+                        && isIDFIRST_lazy_if(HeKEY(entry), HeUTF8(entry)) ) {
                 const char *file;
 		gv = MUTABLE_GV(HeVAL(entry));
 		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
@@ -2021,8 +2096,10 @@ Perl_gv_check(pTHX_ const HV *stash)
 		    = 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_get(stash), GvNAME(gv));
+			"Name \"%"HEKf"::%"HEKf
+			"\" used only once: possible typo",
+                            HEKfARG(HvNAME_HEK(stash)),
+                            HEKfARG(GvNAME_HEK(gv)));
 	    }
 	}
     }
@@ -2267,12 +2344,19 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
 			return -1;
 		    }
 		    else {
-			const char * const name = (gvsv && SvPOK(gvsv)) ?  SvPVX_const(gvsv) : "???";
-			Perl_croak(aTHX_ "%s method \"%.256s\" overloading \"%s\" "\
-				    "in package \"%.256s\"",
+			const SV * const name = (gvsv && SvPOK(gvsv))
+                                                    ? gvsv
+                                                    : newSVpvs_flags("???", SVs_TEMP);
+			/* diag_listed_as: Can't resolve method "%s" overloading "%s" in package "%s" */
+			Perl_croak(aTHX_ "%s method \"%"SVf256
+				    "\" overloading \"%s\" "\
+				    "in package \"%"HEKf256"\"",
 				   (GvCVGEN(gv) ? "Stub found while resolving"
 				    : "Can't resolve"),
-				   name, cp, HvNAME(stash));
+				   SVfARG(name), cp,
+                                   HEKfARG(
+					HvNAME_HEK(stash)
+				   ));
 		    }
 		}
 		cv = GvCV(gv = ngv);
@@ -2490,6 +2574,31 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
     return tmpsv ? tmpsv : ref;
 }
 
+bool
+Perl_amagic_is_enabled(pTHX_ int method)
+{
+      SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
+
+      assert(PL_curcop->cop_hints & HINT_NO_AMAGIC);
+
+      if ( !lex_mask || !SvOK(lex_mask) )
+	  /* overloading lexically disabled */
+	  return FALSE;
+      else if ( lex_mask && SvPOK(lex_mask) ) {
+	  /* we have an entry in the hints hash, check if method has been
+	   * masked by overloading.pm */
+	  STRLEN len;
+	  const int offset = method / 8;
+	  const int bit    = method % 8;
+	  char *pv = SvPV(lex_mask, len);
+
+	  /* Bit set, so this overloading operator is disabled */
+	  if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
+	      return FALSE;
+      }
+      return TRUE;
+}
+
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
@@ -2511,23 +2620,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   PERL_ARGS_ASSERT_AMAGIC_CALL;
 
   if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) {
-      SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0);
-
-      if ( !lex_mask || !SvOK(lex_mask) )
-	  /* overloading lexically disabled */
-	  return NULL;
-      else if ( lex_mask && SvPOK(lex_mask) ) {
-	  /* we have an entry in the hints hash, check if method has been
-	   * masked by overloading.pm */
-	  STRLEN len;
-	  const int offset = method / 8;
-	  const int bit    = method % 8;
-	  char *pv = SvPV(lex_mask, len);
-
-	  /* Bit set, so this overloading operator is disabled */
-	  if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) )
-	      return NULL;
-      }
+      if (!amagic_is_enabled(method)) return NULL;
   }
 
   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
@@ -2735,25 +2828,25 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	SV *msg;
 	if (off==-1) off=method;
 	msg = sv_2mortal(Perl_newSVpvf(aTHX_
-		      "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_get(SvSTASH(SvRV(left))):
-		        "",
-		      SvAMAGIC(right)?
-		        ",\n\tright argument in overloaded package ":
-		        (flags & AMGf_unary
-			 ? ""
-			 : ",\n\tright argument has no overloaded magic"),
-		      SvAMAGIC(right)?
-		        HvNAME_get(SvSTASH(SvRV(right))):
-		        ""));
+		      "Operation \"%s\": no method found,%sargument %s%"SVf"%s%"SVf,
+ 		      AMG_id2name(method + assignshift),
+ 		      (flags & AMGf_unary ? " " : "\n\tleft "),
+ 		      SvAMAGIC(left)?
+ 		        "in overloaded package ":
+ 		        "has no overloaded magic",
+ 		      SvAMAGIC(left)?
+		        SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(left)))))):
+		        SVfARG(&PL_sv_no),
+ 		      SvAMAGIC(right)?
+ 		        ",\n\tright argument in overloaded package ":
+ 		        (flags & AMGf_unary
+ 			 ? ""
+ 			 : ",\n\tright argument has no overloaded magic"),
+ 		      SvAMAGIC(right)?
+		        SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(SvSTASH(SvRV(right)))))):
+		        SVfARG(&PL_sv_no)));
         if (use_default_op) {
-	  DEBUG_o( Perl_deb(aTHX_ "%s", SvPVX_const(msg)) );
+	  DEBUG_o( Perl_deb(aTHX_ "%"SVf, SVfARG(msg)) );
 	} else {
 	  Perl_croak(aTHX_ "%"SVf, SVfARG(msg));
 	}
@@ -2765,7 +2858,7 @@ 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 %"SVf"%s\n",
 		     AMG_id2name(off),
 		     method+assignshift==off? "" :
 		     " (initially \"",
@@ -2775,7 +2868,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 		     flags & AMGf_unary? "" :
 		     lr==1 ? " for right argument": " for left argument",
 		     flags & AMGf_unary? " for argument" : "",
-		     stash ? HvNAME_get(stash) : "null",
+		     stash ? SVfARG(sv_2mortal(newSVhek(HvNAME_HEK(stash)))) : SVfARG(newSVpvs_flags("null", SVs_TEMP)),
 		     fl? ",\n\tassignment variant used": "") );
   }
 #endif
@@ -2801,9 +2894,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
     /*	off is method, method+assignshift, or a result of opcode substitution.
      *	In the latter case assignshift==0, so only notfound case is important.
      */
-  if (( (method + assignshift == off)
+  if ( (lr == -1) && ( ( (method + assignshift == off)
 	&& (assign || (method == inc_amg) || (method == dec_amg)))
-      || force_cpy)
+      || force_cpy) )
   {
       /* newSVsv does not behave as advertised, so we copy missing
        * information by hand */
@@ -2915,7 +3008,7 @@ Perl_gv_name_set(pTHX_ GV *gv, const char *name, U32 len, U32 flags)
     }
 
     PERL_HASH(hash, name, len);
-    GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -len : len), hash);
+    GvNAME_HEK(gv) = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
 }
 
 /*