X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/0ac0412a111b224c7f0c310960dde8b2a3fdad89..5b35fc8b5884b43fcc53d952f9dc9ad629b742f1:/gv.c

diff --git a/gv.c b/gv.c
index f0e685b..aaae2a2 100644
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,7 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -16,10 +17,26 @@
  * laughed Pippin.
  */
 
+/*
+=head1 GV Functions
+
+A GV is a structure which corresponds to to a Perl typeglob, ie *foo.
+It is a structure that holds a pointer to a scalar, an array, a hash etc,
+corresponding to $foo, @foo, %foo.
+
+GVs are usually found as values in stashes (symbol table hashes) where
+Perl stores its global variables.
+
+=cut
+*/
+
 #include "EXTERN.h"
 #define PERL_IN_GV_C
 #include "perl.h"
 
+static const char S_autoload[] = "AUTOLOAD";
+static const STRLEN S_autolen = sizeof(S_autoload)-1;
+
 GV *
 Perl_gv_AVadd(pTHX_ register GV *gv)
 {
@@ -91,24 +108,27 @@ Perl_gv_fetchfile(pTHX_ const char *name)
 void
 Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 {
+    dVAR;
     register GP *gp;
-    bool doproto = SvTYPE(gv) > SVt_NULL;
-    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
+    const bool doproto = SvTYPE(gv) > SVt_NULL;
+    const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
 
     sv_upgrade((SV*)gv, SVt_PVGV);
     if (SvLEN(gv)) {
 	if (proto) {
-	    SvPVX(gv) = NULL;
-	    SvLEN(gv) = 0;
+	    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);
-    GvFILE(gv) = CopFILE(PL_curcop) ? CopFILE(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);
@@ -129,13 +149,6 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 	CvGV(GvCV(gv)) = gv;
 	CvFILE_set_from_cop(GvCV(gv), PL_curcop);
 	CvSTASH(GvCV(gv)) = PL_curstash;
-#ifdef USE_5005THREADS
-	CvOWNER(GvCV(gv)) = 0;
-	if (!CvMUTEXP(GvCV(gv))) {
-	    New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
-	    MUTEX_INIT(CvMUTEXP(GvCV(gv)));
-	}
-#endif /* USE_5005THREADS */
 	if (proto) {
 	    sv_setpv((SV*)GvCV(gv), proto);
 	    Safefree(proto);
@@ -188,6 +201,7 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
     GV* gv;
     GV** gvp;
     CV* cv;
+    const char *hvname;
 
     /* UNIVERSAL methods should be callable without a stash */
     if (!stash) {
@@ -196,11 +210,16 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    return 0;
     }
 
+    hvname = HvNAME_get(stash);
+    if (!hvname)
+      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));
+	      name, hvname);
 
-    DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
+    DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,hvname) );
 
     gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
     if (!gvp)
@@ -227,19 +246,18 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 
     /* create and re-create @.*::SUPER::ISA on demand */
     if (!av || !SvMAGIC(av)) {
-	char* packname = HvNAME(stash);
-	STRLEN packlen = strlen(packname);
+	STRLEN packlen = HvNAMELEN_get(stash);
 
-	if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
+	if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) {
 	    HV* basestash;
 
 	    packlen -= 7;
-	    basestash = gv_stashpvn(packname, packlen, TRUE);
+	    basestash = gv_stashpvn(hvname, 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));
+		    Perl_croak(aTHX_ "Cannot create %s::ISA", hvname);
 		if (SvTYPE(gv) != SVt_PVGV)
 		    gv_init(gv, stash, "ISA", 3, TRUE);
 		SvREFCNT_dec(GvAV(gv));
@@ -257,8 +275,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    HV* basestash = gv_stashsv(sv, FALSE);
 	    if (!basestash) {
 		if (ckWARN(WARN_MISC))
-		    Perl_warner(aTHX_ WARN_MISC, "Can't locate package %s for @%s::ISA",
-			SvPVX(sv), HvNAME(stash));
+		    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
+			sv, hvname);
 		continue;
 	    }
 	    gv = gv_fetchmeth(basestash, name, len,
@@ -306,6 +324,48 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 }
 
 /*
+=for apidoc gv_fetchmeth_autoload
+
+Same as gv_fetchmeth(), but looks for autoloaded subroutines too.
+Returns a glob for the subroutine.
+
+For an autoloaded subroutine without a GV, will create a GV even
+if C<level < 0>.  For an autoloaded subroutine without a stub, GvCV()
+of the result may be zero.
+
+=cut
+*/
+
+GV *
+Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
+{
+    GV *gv = gv_fetchmeth(stash, name, len, level);
+
+    if (!gv) {
+	CV *cv;
+	GV **gvp;
+
+	if (!stash)
+	    return Nullgv;	/* UNIVERSAL::AUTOLOAD could cause trouble */
+	if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
+	    return Nullgv;
+	if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
+	    return Nullgv;
+	cv = GvCV(gv);
+	if (!(CvROOT(cv) || CvXSUB(cv)))
+	    return Nullgv;
+	/* Have an autoload */
+	if (level < 0)	/* Cannot do without a stub */
+	    gv_fetchmeth(stash, name, len, 0);
+	gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+	if (!gvp)
+	    return Nullgv;
+	return *gvp;
+    }
+    return gv;
+}
+
+/*
 =for apidoc gv_fetchmethod
 
 See L<gv_fetchmethod_autoload>.
@@ -353,6 +413,10 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
     register const char *nend;
     const char *nsplit = 0;
     GV* gv;
+    HV* ostash = stash;
+
+    if (stash && SvTYPE(stash) < SVt_PVHV)
+	stash = Nullhv;
 
     for (nend = name; *nend; nend++) {
 	if (*nend == '\'')
@@ -370,13 +434,22 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 	    SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
 						  CopSTASHPV(PL_curcop)));
 	    /* __PACKAGE__::SUPER stash should be autovivified */
-	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
+	    stash = gv_stashpvn(SvPVX_const(tmpstr), SvCUR(tmpstr), TRUE);
 	    DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n",
-			 origname, HvNAME(stash), name) );
+			 origname, HvNAME_get(stash), name) );
 	}
-	else
+	else {
             /* don't autovifify if ->NoSuchStash::method */
             stash = gv_stashpvn(origname, nsplit - origname, FALSE);
+
+	    /* however, explicit calls to Pkg::SUPER::method may
+	       happen, and may require autovivification to work */
+	    if (!stash && (nsplit - origname) >= 7 &&
+		strnEQ(nsplit - 7, "::SUPER", 7) &&
+		gv_stashpvn(origname, nsplit - origname - 7, FALSE))
+	      stash = gv_stashpvn(origname, nsplit - origname, TRUE);
+	}
+	ostash = stash;
     }
 
     gv = gv_fetchmeth(stash, name, nend - name, 0);
@@ -384,7 +457,7 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 	if (strEQ(name,"import") || strEQ(name,"unimport"))
 	    gv = (GV*)&PL_sv_yes;
 	else if (autoload)
-	    gv = gv_autoload4(stash, name, nend - name, TRUE);
+	    gv = gv_autoload4(ostash, name, nend - name, TRUE);
     }
     else if (autoload) {
 	CV* cv = GvCV(gv);
@@ -412,19 +485,28 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 GV*
 Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 {
-    char autoload[] = "AUTOLOAD";
-    STRLEN autolen = sizeof(autoload)-1;
+    dVAR;
     GV* gv;
     CV* cv;
     HV* varstash;
     GV* vargv;
     SV* varsv;
+    const char *packname = "";
+    STRLEN packname_len;
 
-    if (!stash)
-	return Nullgv;	/* UNIVERSAL::AUTOLOAD could cause trouble */
-    if (len == autolen && strnEQ(name, autoload, autolen))
+    if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
 	return Nullgv;
-    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
+    if (stash) {
+	if (SvTYPE(stash) < SVt_PVHV) {
+	    packname = SvPV_const((SV*)stash, packname_len);
+	    stash = Nullhv;
+	}
+	else {
+	    packname = HvNAME_get(stash);
+	    packname_len = HvNAMELEN_get(stash);
+	}
+    }
+    if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
 	return Nullgv;
     cv = GvCV(gv);
 
@@ -434,13 +516,12 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     /*
      * Inheriting AUTOLOAD for non-methods works ... for now.
      */
-    if (ckWARN(WARN_DEPRECATED) && !method &&
+    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
 	(GvCVGEN(gv) || GvSTASH(gv) != stash))
-	Perl_warner(aTHX_ WARN_DEPRECATED,
+	Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
-	     HvNAME(stash), (int)len, name);
+	     packname, (int)len, name);
 
-#ifndef USE_5005THREADS
     if (CvXSUB(cv)) {
         /* rather than lookup/init $AUTOLOAD here
          * only to have the XSUB do another lookup for $AUTOLOAD
@@ -448,11 +529,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
          * pass along the same data via some unused fields in the CV
          */
         CvSTASH(cv) = stash;
-        SvPVX(cv) = (char *)name; /* cast to lose constness warning */
-        SvCUR(cv) = len;
+        SvPV_set(cv, (char *)name); /* cast to lose constness warning */
+        SvCUR_set(cv, len);
         return gv;
     }
-#endif
 
     /*
      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
@@ -461,20 +541,14 @@ 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;
 
-#ifdef USE_5005THREADS
-    sv_lock((SV *)varstash);
-#endif
     if (!isGV(vargv))
-	gv_init(vargv, varstash, autoload, autolen, FALSE);
+	gv_init(vargv, varstash, S_autoload, S_autolen, FALSE);
     LEAVE;
     varsv = GvSV(vargv);
-#ifdef USE_5005THREADS
-    sv_lock(varsv);
-#endif
-    sv_setpv(varsv, HvNAME(stash));
+    sv_setpvn(varsv, packname, packname_len);
     sv_catpvn(varsv, "::", 2);
     sv_catpvn(varsv, name, len);
     SvTAINTED_off(varsv);
@@ -487,14 +561,16 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 STATIC void
 S_require_errno(pTHX_ GV *gv)
 {
+    dVAR;
     HV* stash = gv_stashpvn("Errno",5,FALSE);
 
-    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 
+    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
 	dSP;
 	PUTBACK;
 	ENTER;
 	save_scalar(gv); /* keep the value of $! */
-	require_pv("Errno.pm");
+        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+                         newSVpvn("Errno",5), Nullsv);
 	LEAVE;
 	SPAGAIN;
 	stash = gv_stashpvn("Errno",5,FALSE);
@@ -507,9 +583,9 @@ S_require_errno(pTHX_ GV *gv)
 =for apidoc gv_stashpv
 
 Returns a pointer to the stash for a specified package.  C<name> should
-be a valid UTF-8 string.  If C<create> is set then the package will be
-created if it does not already exist.  If C<create> is not set and the
-package does not exist then NULL is returned.
+be a valid UTF-8 string and must be null-terminated.  If C<create> is set
+then the package will be created if it does not already exist.  If C<create>
+is not set and the package does not exist then NULL is returned.
 
 =cut
 */
@@ -520,6 +596,18 @@ Perl_gv_stashpv(pTHX_ const char *name, I32 create)
     return gv_stashpvn(name, strlen(name), create);
 }
 
+/*
+=for apidoc gv_stashpvn
+
+Returns a pointer to the stash for a specified package.  C<name> should
+be a valid UTF-8 string.  The C<namelen> parameter indicates the length of
+the C<name>, in bytes.  If C<create> is set then the package will be
+created if it does not already exist.  If C<create> is not set and the
+package does not exist then NULL is returned.
+
+=cut
+*/
+
 HV*
 Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
 {
@@ -544,8 +632,8 @@ Perl_gv_stashpvn(pTHX_ const char *name, U32 namelen, I32 create)
     if (!GvHV(tmpgv))
 	GvHV(tmpgv) = newHV();
     stash = GvHV(tmpgv);
-    if (!HvNAME(stash))
-	HvNAME(stash) = savepv(name);
+    if (!HvNAME_get(stash))
+	Perl_hv_name_set(aTHX_ stash, name, namelen, 0);
     return stash;
 }
 
@@ -561,15 +649,27 @@ valid UTF-8 string.  See C<gv_stashpv>.
 HV*
 Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 {
-    register char *ptr;
     STRLEN len;
-    ptr = SvPV(sv,len);
+    const char *ptr = SvPV_const(sv,len);
     return gv_stashpvn(ptr, len, create);
 }
 
 
 GV *
-Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
+    return gv_fetchpvn_flags(nambeg, strlen(nambeg), add, sv_type);
+}
+
+GV *
+Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
+    STRLEN len;
+    const char *nambeg = SvPV_const(name, len);
+    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)
 {
     register const char *name = nambeg;
     register GV *gv = 0;
@@ -577,6 +677,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     I32 len;
     register const char *namend;
     HV *stash = 0;
+    const I32 add = flags & ~SVf_UTF8;
+    (void)full_len;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 	name++;
@@ -595,7 +697,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 		char smallbuf[256];
 		char *tmpbuf;
 
-		if (len + 3 < sizeof smallbuf)
+		if (len + 3 < sizeof (smallbuf))
 		    tmpbuf = smallbuf;
 		else
 		    New(601, tmpbuf, len+3, char);
@@ -619,8 +721,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 		if (!(stash = GvHV(gv)))
 		    stash = GvHV(gv) = newHV();
 
-		if (!HvNAME(stash))
-		    HvNAME(stash) = savepvn(nambeg, namend - nambeg);
+		if (!HvNAME_get(stash))
+		    Perl_hv_name_set(aTHX_ stash, nambeg, namend - nambeg, 0);
 	    }
 
 	    if (*namend == ':')
@@ -632,8 +734,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	}
     }
     len = namend - name;
-    if (!len)
-	len = 1;
 
     /* No stash in name, so see how we can default */
 
@@ -641,35 +741,43 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	if (isIDFIRST_lazy(name)) {
 	    bool global = FALSE;
 
-	    if (isUPPER(*name)) {
-		if (*name == 'S' && (
-		    strEQ(name, "SIG") ||
-		    strEQ(name, "STDIN") ||
-		    strEQ(name, "STDOUT") ||
-		    strEQ(name, "STDERR")))
+	    /* 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':
+		if (*name == '_')
+		    global = TRUE;
+		break;
+	    case 'N':
+		if (strEQ(name, "INC") || strEQ(name, "ENV"))
 		    global = TRUE;
-		else if (*name == 'I' && strEQ(name, "INC"))
+		break;
+	    case 'I':
+		if (strEQ(name, "SIG"))
 		    global = TRUE;
-		else if (*name == 'E' && strEQ(name, "ENV"))
+		break;
+	    case 'T':
+		if (strEQ(name, "STDIN") || strEQ(name, "STDOUT") ||
+		    strEQ(name, "STDERR"))
 		    global = TRUE;
-		else if (*name == 'A' && (
-		  strEQ(name, "ARGV") ||
-		  strEQ(name, "ARGVOUT")))
+		break;
+	    case 'R':
+		if (strEQ(name, "ARGV") || strEQ(name, "ARGVOUT"))
 		    global = TRUE;
+		break;
 	    }
-	    else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__")))
-		global = TRUE;
 
 	    if (global)
 		stash = PL_defstash;
-	    else if ((COP*)PL_curcop == &PL_compiling) {
+	    else if (IN_PERL_COMPILETIME) {
 		stash = PL_curstash;
 		if (add && (PL_hints & HINT_STRICT_VARS) &&
 		    sv_type != SVt_PVCV &&
 		    sv_type != SVt_PVGV &&
 		    sv_type != SVt_PVFM &&
 		    sv_type != SVt_PVIO &&
-		    !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
+		    !(len == 1 && sv_type == SVt_PV &&
+		      (*name == 'a' || *name == 'b')) )
 		{
 		    gvp = (GV**)hv_fetch(stash,name,len,0);
 		    if (!gvp ||
@@ -703,13 +811,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 
     if (!stash) {
 	if (add) {
-	    qerror(Perl_mess(aTHX_
+	    register SV *err = Perl_mess(aTHX_
 		 "Global symbol \"%s%s\" requires explicit package name",
 		 (sv_type == SVt_PV ? "$"
 		  : sv_type == SVt_PVAV ? "@"
 		  : sv_type == SVt_PVHV ? "%"
-		  : ""), name));
-	    stash = PL_nullstash;
+		  : ""), name);
+	    if (USE_UTF8_IN_NAMES)
+		SvUTF8_on(err);
+	    qerror(err);
+	    stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 	}
 	else
 	    return Nullgv;
@@ -737,370 +848,378 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     /* Adding a new symbol */
 
     if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
-	Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg);
+	Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, sv_type);
 
-    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) ;
 
     /* set up magic where warranted */
-    switch (*name) {
-    case 'A':
-	if (strEQ(name, "ARGV")) {
-	    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
-	}
-	break;
-    case 'E':
-	if (strnEQ(name, "EXPORT", 6))
-	    GvMULTI_on(gv);
-	break;
-    case 'I':
-	if (strEQ(name, "ISA")) {
-	    AV* av = GvAVn(gv);
-	    GvMULTI_on(gv);
-	    sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
-	    /* NOTE: No support for tied ISA */
-	    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
-		&& AvFILLp(av) == -1)
+    if (len > 1) {
+#ifndef EBCDIC
+	if (*name > 'V' ) {
+	    /* 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
+	       the common case of lower case variable names.  */
+	} else
+#endif
+	{
+	    const char * const name2 = name + 1;
+	    switch (*name) {
+	    case 'A':
+		if (strEQ(name2, "RGV")) {
+		    IoFLAGS(GvIOn(gv)) |= IOf_ARGV|IOf_START;
+		}
+		break;
+	    case 'E':
+		if (strnEQ(name2, "XPORT", 5))
+		    GvMULTI_on(gv);
+		break;
+	    case 'I':
+		if (strEQ(name2, "SA")) {
+		    AV* av = GvAVn(gv);
+		    GvMULTI_on(gv);
+		    sv_magic((SV*)av, (SV*)gv, PERL_MAGIC_isa, Nullch, 0);
+		    /* NOTE: No support for tied ISA */
+		    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+			&& AvFILLp(av) == -1)
+			{
+			    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);
+			}
+		}
+		break;
+	    case 'O':
+		if (strEQ(name2, "VERLOAD")) {
+		    HV* hv = GvHVn(gv);
+		    GvMULTI_on(gv);
+		    hv_magic(hv, Nullgv, PERL_MAGIC_overload);
+		}
+		break;
+	    case 'S':
+		if (strEQ(name2, "IG")) {
+		    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);
+		    }
+		    GvMULTI_on(gv);
+		    hv = GvHVn(gv);
+		    hv_magic(hv, Nullgv, PERL_MAGIC_sig);
+		    for (i = 1; i < SIG_SIZE; i++) {
+			SV ** init;
+			init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
+			if (init)
+			    sv_setsv(*init, &PL_sv_undef);
+			PL_psig_ptr[i] = 0;
+			PL_psig_name[i] = 0;
+			PL_psig_pend[i] = 0;
+		    }
+		}
+		break;
+	    case 'V':
+		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 '\017':	/* $^OPEN */
+		if (strEQ(name2, "PEN"))
+		    goto magicalize;
+		break;
+	    case '\024':	/* ${^TAINT} */
+		if (strEQ(name2, "AINT"))
+		    goto ro_magicalize;
+		break;
+	    case '\025':	/* ${^UNICODE}, ${^UTF8LOCALE} */
+		if (strEQ(name2, "NICODE"))
+		    goto ro_magicalize;
+		if (strEQ(name2, "TF8LOCALE"))
+		    goto ro_magicalize;
+		break;
+	    case '\027':	/* $^WARNING_BITS */
+		if (strEQ(name2, "ARNING_BITS"))
+		    goto magicalize;
+		break;
+	    case '1':
+	    case '2':
+	    case '3':
+	    case '4':
+	    case '5':
+	    case '6':
+	    case '7':
+	    case '8':
+	    case '9':
 	    {
-		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);
-	    }
-	}
-	break;
-    case 'O':
-        if (strEQ(name, "OVERLOAD")) {
-            HV* hv = GvHVn(gv);
-            GvMULTI_on(gv);
-            hv_magic(hv, Nullgv, PERL_MAGIC_overload);
-        }
-        break;
-    case 'S':
-	if (strEQ(name, "SIG")) {
-	    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);
+		/* ensures variable is only digits */
+		/* ${"1foo"} fails this test (and is thus writeable) */
+		/* added by japhy, but borrowed from is_gv_magical */
+		const char *end = name + len;
+		while (--end > name) {
+		    if (!isDIGIT(*end)) return gv;
+		}
+		goto ro_magicalize;
 	    }
-	    GvMULTI_on(gv);
-	    hv = GvHVn(gv);
-	    hv_magic(hv, Nullgv, PERL_MAGIC_sig);
-	    for (i = 1; i < SIG_SIZE; i++) {
-	    	SV ** init;
-	    	init = hv_fetch(hv, PL_sig_name[i], strlen(PL_sig_name[i]), 1);
-	    	if (init)
-		    sv_setsv(*init, &PL_sv_undef);
-	    	PL_psig_ptr[i] = 0;
-	    	PL_psig_name[i] = 0;
-	    	PL_psig_pend[i] = 0;
 	    }
 	}
-	break;
-    case 'V':
-	if (strEQ(name, "VERSION"))
-	    GvMULTI_on(gv);
-	break;
-
-    case '&':
-    case '`':
-    case '\'':
-       if (
-           len > 1 ||
-           sv_type == SVt_PVAV ||
-           sv_type == SVt_PVHV ||
-           sv_type == SVt_PVCV ||
-           sv_type == SVt_PVFM ||
-           sv_type == SVt_PVIO
-       ) { break; }
-	PL_sawampersand = TRUE;
-	goto ro_magicalize;
-
-    case ':':
-	if (len > 1)
-	    break;
-	sv_setpv(GvSV(gv),PL_chopset);
-	goto magicalize;
-
-    case '?':
-	if (len > 1)
-	    break;
+    } else {
+	/* Names of length 1.  (Or 0. But name is NUL terminated, so that will
+	   be case '\0' in this switch statement (ie a default case)  */
+	switch (*name) {
+	case '&':
+	case '`':
+	case '\'':
+	    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;
+	    goto ro_magicalize;
+
+	case ':':
+	    sv_setpv(GvSV(gv),PL_chopset);
+	    goto magicalize;
+
+	case '?':
 #ifdef COMPLEX_STATUS
-	(void)SvUPGRADE(GvSV(gv), SVt_PVLV);
+	    SvUPGRADE(GvSV(gv), SVt_PVLV);
 #endif
-	goto magicalize;
+	    goto magicalize;
 
-    case '!':
-	if (len > 1)
-	    break;
+	case '!':
 
-	/* 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)
-	*/
+	    /* 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(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
 
-	if (sv_type == SVt_PVHV)
-	    require_errno(gv);
+	    if (sv_type == SVt_PVHV)
+		require_errno(gv);
 
-	break;
-    case '-':
-	if (len > 1)
 	    break;
-	else {
+	case '-':
+	{
             AV* av = GvAVn(gv);
             sv_magic((SV*)av, Nullsv, PERL_MAGIC_regdata, Nullch, 0);
 	    SvREADONLY_on(av);
-        }
-	goto magicalize;
-    case '#':
-    case '*':
-	if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
-	    Perl_warner(aTHX_ WARN_DEPRECATED, "Use of $%s is deprecated", name);
-	/* FALL THROUGH */
-    case '[':
-    case '^':
-    case '~':
-    case '=':
-    case '%':
-    case '.':
-    case '(':
-    case ')':
-    case '<':
-    case '>':
-    case ',':
-    case '\\':
-    case '/':
-    case '\001':	/* $^A */
-    case '\003':	/* $^C */
-    case '\004':	/* $^D */
-    case '\006':	/* $^F */
-    case '\010':	/* $^H */
-    case '\011':	/* $^I, NOT \t in EBCDIC */
-    case '\016':        /* $^N */
-    case '\020':	/* $^P */
-	if (len > 1)
-	    break;
-	goto magicalize;
-    case '|':
-	if (len > 1)
-	    break;
-	sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
-	goto magicalize;
-    case '\005':	/* $^E && $^ENCODING */
-	if (len > 1 && strNE(name, "\005NCODING"))
-	    break;
-	goto magicalize;
-
-    case '\017':	/* $^O & $^OPEN */
-	if (len > 1 && strNE(name, "\017PEN"))
-	    break;
-	goto magicalize;
-    case '\023':	/* $^S */
-	if (len > 1)
-	    break;
-	goto ro_magicalize;
-    case '\024':	/* $^T, ${^TAINT} */
-        if (len == 1)
-            goto magicalize;
-        else if (strEQ(name, "\024AINT"))
-            goto ro_magicalize;
-        else
-            break;
-    case '\027':	/* $^W & $^WARNING_BITS */
-	if (len > 1 && strNE(name, "\027ARNING_BITS")
-	    && strNE(name, "\027IDE_SYSTEM_CALLS"))
+	    goto magicalize;
+	}
+	case '*':
+	case '#':
+	    if (sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+		Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+			    "$%c is no longer supported", *name);
 	    break;
-	goto magicalize;
+	case '|':
+	    sv_setiv(GvSV(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
+	    goto magicalize;
 
-    case '+':
-	if (len > 1)
-	    break;
-	else {
-            AV* av = GvAVn(gv);
+	case '+':
+	{
+	    AV* av = GvAVn(gv);
             sv_magic((SV*)av, (SV*)av, PERL_MAGIC_regdata, Nullch, 0);
 	    SvREADONLY_on(av);
-        }
-	/* FALL THROUGH */
-    case '1':
-    case '2':
-    case '3':
-    case '4':
-    case '5':
-    case '6':
-    case '7':
-    case '8':
-    case '9':
-	/* ensures variable is only digits */
-	/* ${"1foo"} fails this test (and is thus writeable) */
-	/* added by japhy, but borrowed from is_gv_magical */
-
-	if (len > 1) {
-	    const char *end = name + len;
-	    while (--end > name) {
-		if (!isDIGIT(*end)) return gv;
-	    }
+	    /* FALL THROUGH */
 	}
+	case '\023':	/* $^S */
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	ro_magicalize:
+	    SvREADONLY_on(GvSV(gv));
+	    /* FALL THROUGH */
+	case '[':
+	case '^':
+	case '~':
+	case '=':
+	case '%':
+	case '.':
+	case '(':
+	case ')':
+	case '<':
+	case '>':
+	case ',':
+	case '\\':
+	case '/':
+	case '\001':	/* $^A */
+	case '\003':	/* $^C */
+	case '\004':	/* $^D */
+	case '\005':	/* $^E */
+	case '\006':	/* $^F */
+	case '\010':	/* $^H */
+	case '\011':	/* $^I, NOT \t in EBCDIC */
+	case '\016':	/* $^N */
+	case '\017':	/* $^O */
+	case '\020':	/* $^P */
+	case '\024':	/* $^T */
+	case '\027':	/* $^W */
+	magicalize:
+	    sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
+	    break;
 
-      ro_magicalize:
-	SvREADONLY_on(GvSV(gv));
-      magicalize:
-	sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, len);
-	break;
-
-    case '\014':	/* $^L */
-	if (len > 1)
+	case '\014':	/* $^L */
+	    sv_setpvn(GvSV(gv),"\f",1);
+	    PL_formfeed = GvSV(gv);
 	    break;
-	sv_setpv(GvSV(gv),"\f");
-	PL_formfeed = GvSV(gv);
-	break;
-    case ';':
-	if (len > 1)
+	case ';':
+	    sv_setpvn(GvSV(gv),"\034",1);
 	    break;
-	sv_setpv(GvSV(gv),"\034");
-	break;
-    case ']':
-	if (len == 1) {
+	case ']':
+	{
 	    SV *sv = GvSV(gv);
-	    (void)SvUPGRADE(sv, SVt_PVNV);
-	    Perl_sv_setpvf(aTHX_ sv,
-#if defined(PERL_SUBVERSION) && (PERL_SUBVERSION > 0)
-			    "%8.6"
-#else
-			    "%5.3"
-#endif
-			    NVff,
-			    SvNVX(PL_patchlevel));
-	    SvNVX(sv) = SvNVX(PL_patchlevel);
-	    SvNOK_on(sv);
-	    SvREADONLY_on(sv);
+	    if (!sv_derived_from(PL_patchlevel, "version"))
+		(void *)upg_version(PL_patchlevel);
+	    GvSV(gv) = vnumify(PL_patchlevel);
+	    SvREADONLY_on(GvSV(gv));
+	    SvREFCNT_dec(sv);
 	}
 	break;
-    case '\026':	/* $^V */
-	if (len == 1) {
-	    SV *sv = GvSV(gv);
-	    GvSV(gv) = SvREFCNT_inc(PL_patchlevel);
+	case '\026':	/* $^V */
+	{
+	    SV * const sv = GvSV(gv);
+	    GvSV(gv) = new_version(PL_patchlevel);
+	    SvREADONLY_on(GvSV(gv));
 	    SvREFCNT_dec(sv);
 	}
 	break;
+	}
     }
     return gv;
 }
 
 void
-Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+Perl_gv_fullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    HV *hv = GvSTASH(gv);
+    const char *name;
+    STRLEN namelen;
+    const HV * const hv = GvSTASH(gv);
     if (!hv) {
-	(void)SvOK_off(sv);
+	SvOK_off(sv);
 	return;
     }
     sv_setpv(sv, prefix ? prefix : "");
-    if (keepmain || strNE(HvNAME(hv), "main")) {
-	sv_catpv(sv,HvNAME(hv));
+
+    name = HvNAME_get(hv);
+    if (name) {
+	namelen = HvNAMELEN_get(hv);
+    } else {
+	name = "__ANON__";
+	namelen = 8;
+    }
+
+    if (keepmain || strNE(name, "main")) {
+	sv_catpvn(sv,name,namelen);
 	sv_catpvn(sv,"::", 2);
     }
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 }
 
 void
-Perl_gv_fullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
+Perl_gv_fullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 {
-    HV *hv = GvSTASH(gv);
-    if (!hv) {
-	(void)SvOK_off(sv);
-	return;
-    }
-    sv_setpv(sv, prefix ? prefix : "");
-    sv_catpv(sv,HvNAME(hv));
-    sv_catpvn(sv,"::", 2);
-    sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
+    gv_fullname4(sv, gv, prefix, TRUE);
 }
 
 void
-Perl_gv_efullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
+Perl_gv_efullname4(pTHX_ SV *sv, const GV *gv, const char *prefix, bool keepmain)
 {
-    GV *egv = GvEGV(gv);
+    const GV *egv = GvEGV(gv);
     if (!egv)
 	egv = gv;
     gv_fullname4(sv, egv, prefix, keepmain);
 }
 
 void
-Perl_gv_efullname3(pTHX_ SV *sv, GV *gv, const char *prefix)
+Perl_gv_efullname3(pTHX_ SV *sv, const GV *gv, const char *prefix)
 {
-    GV *egv = GvEGV(gv);
-    if (!egv)
-	egv = gv;
-    gv_fullname3(sv, egv, prefix);
+    gv_efullname4(sv, gv, prefix, TRUE);
 }
 
-/* XXX compatibility with versions <= 5.003. */
+/* compatibility with versions <= 5.003. */
 void
-Perl_gv_fullname(pTHX_ SV *sv, GV *gv)
+Perl_gv_fullname(pTHX_ SV *sv, const GV *gv)
 {
-    gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+    gv_fullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 }
 
-/* XXX compatibility with versions <= 5.003. */
+/* compatibility with versions <= 5.003. */
 void
-Perl_gv_efullname(pTHX_ SV *sv, GV *gv)
+Perl_gv_efullname(pTHX_ SV *sv, const GV *gv)
 {
-    gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+    gv_efullname3(sv, gv, sv == (const SV*)gv ? "*" : "");
 }
 
 IO *
 Perl_newIO(pTHX)
 {
-    IO *io;
     GV *iogv;
+    IO * const io = (IO*)NEWSV(0,0);
 
-    io = (IO*)NEWSV(0,0);
     sv_upgrade((SV *)io,SVt_PVIO);
     SvREFCNT(io) = 1;
     SvOBJECT_on(io);
+    /* Clear the stashcache because a new IO could overrule a package name */
+    hv_clear(PL_stashcache);
     iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
     /* unless exists($main::{FileHandle}) and defined(%main::FileHandle::) */
     if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
       iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
-    SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
+    SvSTASH_set(io, (HV*)SvREFCNT_inc(GvHV(iogv)));
     return io;
 }
 
 void
 Perl_gv_check(pTHX_ HV *stash)
 {
-    register HE *entry;
     register I32 i;
-    register GV *gv;
-    HV *hv;
 
     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)) && (hv = GvHV(gv)))
+		(gv = (GV*)HeVAL(entry)) && isGV(gv) && (hv = GvHV(gv)))
 	    {
 		if (hv != PL_defstash && hv != stash)
 		     gv_check(hv);              /* nested package */
 	    }
 	    else if (isALPHA(*HeKEY(entry))) {
-		char *file;
+                const char *file;
 		gv = (GV*)HeVAL(entry);
 		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 		    continue;
@@ -1120,20 +1239,20 @@ Perl_gv_check(pTHX_ HV *stash)
 		}
 		CopLINE_set(PL_curcop, GvLINE(gv));
 #ifdef USE_ITHREADS
-		CopFILE(PL_curcop) = file;	/* set for warning */
+		CopFILE(PL_curcop) = (char *)file;	/* set for warning */
 #else
 		CopFILEGV(PL_curcop) = gv_fetchfile(file);
 #endif
-		Perl_warner(aTHX_ WARN_ONCE,
+		Perl_warner(aTHX_ packWARN(WARN_ONCE),
 			"Name \"%s::%s\" used only once: possible typo",
-			HvNAME(stash), GvNAME(gv));
+			HvNAME_get(stash), GvNAME(gv));
 	    }
 	}
     }
 }
 
 GV *
-Perl_newGVgen(pTHX_ char *pack)
+Perl_newGVgen(pTHX_ const char *pack)
 {
     return gv_fetchpv(Perl_form(aTHX_ "%s::_GEN_%ld", pack, (long)PL_gensym++),
 		      TRUE, SVt_PVGV);
@@ -1171,8 +1290,9 @@ Perl_gp_free(pTHX_ GV *gv)
 	return;
     if (gp->gp_refcnt == 0) {
 	if (ckWARN_d(WARN_INTERNAL))
-	    Perl_warner(aTHX_ WARN_INTERNAL,
-			"Attempt to free unreferenced glob pointers");
+	    Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+			"Attempt to free unreferenced glob pointers"
+                        pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (gp->gp_cv) {
@@ -1185,49 +1305,35 @@ Perl_gp_free(pTHX_ GV *gv)
         return;
     }
 
-    SvREFCNT_dec(gp->gp_sv);
-    SvREFCNT_dec(gp->gp_av);
-    SvREFCNT_dec(gp->gp_hv);
-    SvREFCNT_dec(gp->gp_io);
-    SvREFCNT_dec(gp->gp_cv);
-    SvREFCNT_dec(gp->gp_form);
+    if (gp->gp_sv) SvREFCNT_dec(gp->gp_sv);
+    if (gp->gp_av) 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)
+	    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);
 
     Safefree(gp);
     GvGP(gv) = 0;
 }
 
-#if defined(CRIPPLED_CC) && (defined(iAPX286) || defined(M_I286) || defined(I80286))
-#define MICROPORT
-#endif
-
-#ifdef	MICROPORT	/* Microport 2.4 hack */
-AV *GvAVn(gv)
-register GV *gv;
-{
-    if (GvGP(gv)->gp_av)
-	return GvGP(gv)->gp_av;
-    else
-	return GvGP(gv_AVadd(gv))->gp_av;
-}
-
-HV *GvHVn(gv)
-register GV *gv;
-{
-    if (GvGP(gv)->gp_hv)
-	return GvGP(gv)->gp_hv;
-    else
-	return GvGP(gv_HVadd(gv))->gp_hv;
-}
-#endif			/* Microport 2.4 hack */
-
 int
 Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
 {
-    AMT *amtp = (AMT*)mg->mg_ptr;
+    AMT * const amtp = (AMT*)mg->mg_ptr;
+    PERL_UNUSED_ARG(sv);
+
     if (amtp && AMT_AMAGIC(amtp)) {
 	int i;
 	for (i = 1; i < NofAMmeth; i++) {
-	    CV *cv = amtp->table[i];
+	    CV * const cv = amtp->table[i];
 	    if (cv != Nullcv) {
 		SvREFCNT_dec((SV *) cv);
 		amtp->table[i] = Nullcv;
@@ -1242,18 +1348,16 @@ 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;
+  MAGIC* const mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
+  AMT * const amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
 
   if (mg && amtp->was_ok_am == PL_amagic_generation
       && amtp->was_ok_sub == PL_sub_generation)
-      return AMT_OVERLOADED(amtp);
+      return (bool)AMT_OVERLOADED(amtp);
   sv_unmagic((SV*)stash, PERL_MAGIC_overload_table);
 
-  DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
+  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;
@@ -1264,14 +1368,13 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
   {
     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. */
@@ -1283,46 +1386,61 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
     for (i = 1; i < lim; i++)
 	amt.table[i] = Nullcv;
     for (; i < NofAMmeth; i++) {
-	char *cooky = (char*)PL_AMG_names[i];
+	const char *cooky = PL_AMG_names[i];
 	/* Human-readable form, for debugging: */
-	char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
-	STRLEN l = strlen(cooky);
-
-	DEBUG_o( Perl_deb(aTHX_ "Checking overloading of `%s' in package `%.256s'\n",
-		     cp, HvNAME(stash)) );
-	/* don't fill the cache while looking up! */
-	gv = gv_fetchmeth(stash, cooky, l, -1);
+	const char *cp = (i >= DESTROY_amg ? cooky : AMG_id2name(i));
+	const STRLEN l = strlen(cooky);
+
+	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.
+	   Indeed, for inheritance A -> B -> C, if C overloads "+0",
+	   then we could have created stubs for "(+0" in A and C too.
+	   But if B overloads "bool", we may want to use it for
+	   numifying instead of C's "+0". */
+	if (i >= DESTROY_amg)
+	    gv = Perl_gv_fetchmeth_autoload(aTHX_ stash, cooky, l, 0);
+	else				/* Autoload taken care of below */
+	    gv = Perl_gv_fetchmeth(aTHX_ stash, cooky, l, -1);
         cv = 0;
         if (gv && (cv = GvCV(gv))) {
+	    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;
-		
-		DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
-			     SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
+		GV *ngv = Nullgv;
+
+		DEBUG_o( Perl_deb(aTHX_ "Resolving method \"%"SVf256\
+			"\" for overloaded \"%s\" in package \"%.256s\"\n",
+			     GvSV(gv), cp, hvname) );
 		if (!SvPOK(GvSV(gv))
-		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX_const(GvSV(gv)),
 						       FALSE)))
 		{
-		    /* Can be an import stub (created by `can'). */
-		    if (GvCVGEN(gv)) {
-			Perl_croak(aTHX_ "Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'",
-			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
-			      cp, HvNAME(stash));
-		    } else
-			Perl_croak(aTHX_ "Can't resolve method `%.256s' overloading `%s' in package `%.256s'",
-			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
-			      cp, HvNAME(stash));
+		    /* Can be an import stub (created by "can"). */
+		    SV *gvsv = GvSV(gv);
+		    const char * const name = 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);
 		}
 		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;
+	    filled = 1;
 	}
 	amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
@@ -1350,7 +1468,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     MAGIC *mg;
     AMT *amtp;
 
-    if (!stash)
+    if (!stash || !HvNAME_get(stash))
         return Nullcv;
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
@@ -1362,8 +1480,21 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     if ( amtp->was_ok_am != PL_amagic_generation
 	 || amtp->was_ok_sub != PL_sub_generation )
 	goto do_update;
-    if (AMT_AMAGIC(amtp))
-	return amtp->table[id];
+    if (AMT_AMAGIC(amtp)) {
+	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]);
+
+	    if (gv && GvCV(gv))
+		return GvCV(gv);
+	}
+	return ret;
+    }
+
     return Nullcv;
 }
 
@@ -1371,12 +1502,15 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {
+  dVAR;
   MAGIC *mg;
   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
@@ -1393,7 +1527,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 		  (
 #ifdef DEBUGGING
 		   fl = 1,
-#endif 
+#endif
 		   cv = cvp[off=method])))) {
     lr = -1;			/* Call method for left argument */
   } else {
@@ -1426,12 +1560,12 @@ 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:
 	   {
 	     /*
@@ -1446,7 +1580,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 		 */
 		SV* newref = newSVsv(tmpRef);
 		SvOBJECT_on(newref);
-		SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(tmpRef));
+		SvSTASH_set(newref, (HV*)SvREFCNT_inc(SvSTASH(tmpRef)));
 		return newref;
 	     }
 	   }
@@ -1560,14 +1694,14 @@ 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",
+		      "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 ":
@@ -1575,10 +1709,10 @@ 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);
 	}
@@ -1590,17 +1724,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
@@ -1634,7 +1768,7 @@ 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);
@@ -1672,7 +1806,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:
@@ -1697,6 +1831,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) {
@@ -1711,6 +1847,22 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 }
 
 /*
+=for apidoc is_gv_magical_sv
+
+Returns C<TRUE> 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_const(name, len);
+    return is_gv_magical(temp, len, flags);
+}
+
+/*
 =for apidoc is_gv_magical
 
 Returns C<TRUE> if given the name of a magical GV.
@@ -1721,108 +1873,138 @@ created even in rvalue contexts.
 C<flags> is not used at present but available for future extension to
 allow selecting particular classes of magical variable.
 
+Currently assumes that C<name> is NUL terminated (as well as len being valid).
+This assumption is met by all callers within the perl core, which all pass
+pointers returned by SvPV.
+
 =cut
 */
 bool
-Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
+Perl_is_gv_magical(pTHX_ const char *name, STRLEN len, U32 flags)
 {
-    if (!len)
-	return FALSE;
-
-    switch (*name) {
-    case 'I':
-	if (len == 3 && strEQ(name, "ISA"))
-	    goto yes;
-	break;
-    case 'O':
-	if (len == 8 && strEQ(name, "OVERLOAD"))
-	    goto yes;
-	break;
-    case 'S':
-	if (len == 3 && strEQ(name, "SIG"))
-	    goto yes;
-	break;
-    case '\017':   /* $^O & $^OPEN */
-	if (len == 1
-	    || (len == 4 && strEQ(name, "\027PEN")))
-	{
-	    goto yes;
-	}
-	break;
-    case '\027':   /* $^W & $^WARNING_BITS */
-	if (len == 1
-	    || (len == 12 && strEQ(name, "\027ARNING_BITS"))
-	    || (len == 17 && strEQ(name, "\027IDE_SYSTEM_CALLS")))
+    (void)flags;
+    if (len > 1) {
+	const char * const name1 = name + 1;
+	switch (*name) {
+	case 'I':
+	    if (len == 3 && name1[1] == 'S' && name[2] == 'A')
+		goto yes;
+	    break;
+	case 'O':
+	    if (len == 8 && strEQ(name1, "VERLOAD"))
+		goto yes;
+	    break;
+	case 'S':
+	    if (len == 3 && name[1] == 'I' && name[2] == 'G')
+		goto yes;
+	    break;
+	    /* Using ${^...} variables is likely to be sufficiently rare that
+	       it seems sensible to avoid the space hit of also checking the
+	       length.  */
+	case '\017':   /* ${^OPEN} */
+	    if (strEQ(name1, "PEN"))
+		goto yes;
+	    break;
+	case '\024':   /* ${^TAINT} */
+	    if (strEQ(name1, "AINT"))
+		goto yes;
+	    break;
+	case '\025':	/* ${^UNICODE} */
+	    if (strEQ(name1, "NICODE"))
+		goto yes;
+	    if (strEQ(name1, "TF8LOCALE"))
+		goto yes;
+	    break;
+	case '\027':   /* ${^WARNING_BITS} */
+	    if (strEQ(name1, "ARNING_BITS"))
+		goto yes;
+	    break;
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
 	{
-	    goto yes;
-	}
-	break;
-
-    case '&':
-    case '`':
-    case '\'':
-    case ':':
-    case '?':
-    case '!':
-    case '-':
-    case '#':
-    case '*':
-    case '[':
-    case '^':
-    case '~':
-    case '=':
-    case '%':
-    case '.':
-    case '(':
-    case ')':
-    case '<':
-    case '>':
-    case ',':
-    case '\\':
-    case '/':
-    case '|':
-    case '+':
-    case ';':
-    case ']':
-    case '\001':   /* $^A */
-    case '\003':   /* $^C */
-    case '\004':   /* $^D */
-    case '\005':   /* $^E */
-    case '\006':   /* $^F */
-    case '\010':   /* $^H */
-    case '\011':   /* $^I, NOT \t in EBCDIC */
-    case '\014':   /* $^L */
-    case '\016':   /* $^N */
-    case '\020':   /* $^P */
-    case '\023':   /* $^S */
-    case '\026':   /* $^V */
-	if (len == 1)
-	    goto yes;
-	break;
-    case '\024':   /* $^T, ${^TAINT} */
-        if (len == 1 || strEQ(name, "\024AINT"))
-            goto yes;
-        break;
-    case '1':
-    case '2':
-    case '3':
-    case '4':
-    case '5':
-    case '6':
-    case '7':
-    case '8':
-    case '9':
-	if (len > 1) {
-	    char *end = name + len;
+	    const char *end = name + len;
 	    while (--end > name) {
 		if (!isDIGIT(*end))
 		    return FALSE;
 	    }
+	    goto yes;
+	}
+	}
+    } else {
+	/* Because we're already assuming that name is NUL terminated
+	   below, we can treat an empty name as "\0"  */
+	switch (*name) {
+	case '&':
+	case '`':
+	case '\'':
+	case ':':
+	case '?':
+	case '!':
+	case '-':
+	case '#':
+	case '[':
+	case '^':
+	case '~':
+	case '=':
+	case '%':
+	case '.':
+	case '(':
+	case ')':
+	case '<':
+	case '>':
+	case ',':
+	case '\\':
+	case '/':
+	case '|':
+	case '+':
+	case ';':
+	case ']':
+	case '\001':   /* $^A */
+	case '\003':   /* $^C */
+	case '\004':   /* $^D */
+	case '\005':   /* $^E */
+	case '\006':   /* $^F */
+	case '\010':   /* $^H */
+	case '\011':   /* $^I, NOT \t in EBCDIC */
+	case '\014':   /* $^L */
+	case '\016':   /* $^N */
+	case '\017':   /* $^O */
+	case '\020':   /* $^P */
+	case '\023':   /* $^S */
+	case '\024':   /* $^T */
+	case '\026':   /* $^V */
+	case '\027':   /* $^W */
+	case '1':
+	case '2':
+	case '3':
+	case '4':
+	case '5':
+	case '6':
+	case '7':
+	case '8':
+	case '9':
+	yes:
+	    return TRUE;
+	default:
+	    break;
 	}
-    yes:
-	return TRUE;
-    default:
-	break;
     }
     return FALSE;
 }
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */