X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f86702ccfcc3646d7aa30b09ce4f4413be9f99d1..1d3434b8c1ecb43ba830424cfca969ab84444ed7:/gv.c

diff --git a/gv.c b/gv.c
index 010a391..b48e4d8 100644
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,6 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-1994, Larry Wall
+ *    Copyright (c) 1991-1997, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -22,8 +22,7 @@
 EXT char rcsid[];
 
 GV *
-gv_AVadd(gv)
-register GV *gv;
+gv_AVadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for array");
@@ -33,8 +32,7 @@ register GV *gv;
 }
 
 GV *
-gv_HVadd(gv)
-register GV *gv;
+gv_HVadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for hash");
@@ -44,8 +42,7 @@ register GV *gv;
 }
 
 GV *
-gv_IOadd(gv)
-register GV *gv;
+gv_IOadd(register GV *gv)
 {
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	croak("Bad symbol for filehandle");
@@ -55,39 +52,52 @@ register GV *gv;
 }
 
 GV *
-gv_fetchfile(name)
-char *name;
+gv_fetchfile(char *name)
 {
-    char tmpbuf[1200];
+    dTHR;
+    char smallbuf[256];
+    char *tmpbuf;
     STRLEN tmplen;
     GV *gv;
 
-    sprintf(tmpbuf, "_<%s", name);
-    tmplen = strlen(tmpbuf);
+    tmplen = strlen(name) + 2;
+    if (tmplen < sizeof smallbuf)
+	tmpbuf = smallbuf;
+    else
+	New(603, tmpbuf, tmplen + 1, char);
+    tmpbuf[0] = '_';
+    tmpbuf[1] = '<';
+    strcpy(tmpbuf + 2, name);
     gv = *(GV**)hv_fetch(defstash, tmpbuf, tmplen, TRUE);
     if (!isGV(gv))
 	gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
+    if (tmpbuf != smallbuf)
+	Safefree(tmpbuf);
     sv_setpv(GvSV(gv), name);
     if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
 	GvMULTI_on(gv);
-    if (perldb)
+    if (PERLDB_LINE)
 	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
     return gv;
 }
 
 void
-gv_init(gv, stash, name, len, multi)
-GV *gv;
-HV *stash;
-char *name;
-STRLEN len;
-int multi;
+gv_init(GV *gv, HV *stash, char *name, STRLEN len, int multi)
 {
+    dTHR;
     register GP *gp;
+    bool doproto = SvTYPE(gv) > SVt_NULL;
+    char *proto = (doproto && SvPOK(gv)) ? SvPVX(gv) : NULL;
 
     sv_upgrade((SV*)gv, SVt_PVGV);
-    if (SvLEN(gv))
-	Safefree(SvPVX(gv));
+    if (SvLEN(gv)) {
+	if (proto) {
+	    SvPVX(gv) = NULL;
+	    SvLEN(gv) = 0;
+	    SvPOK_off(gv);
+	} else
+	    Safefree(SvPVX(gv));
+    }
     Newz(602, gp, 1, GP);
     GvGP(gv) = gp_ref(gp);
     GvSV(gv) = NEWSV(72,0);
@@ -95,17 +105,36 @@ int multi;
     GvFILEGV(gv) = curcop->cop_filegv;
     GvEGV(gv) = gv;
     sv_magic((SV*)gv, (SV*)gv, '*', name, len);
-    GvSTASH(gv) = stash;
+    GvSTASH(gv) = (HV*)SvREFCNT_inc(stash);
     GvNAME(gv) = savepvn(name, len);
     GvNAMELEN(gv) = len;
     if (multi)
 	GvMULTI_on(gv);
+    if (doproto) {			/* Replicate part of newSUB here. */
+	ENTER;
+	start_subparse(0,0);		/* Create CV in compcv. */
+	GvCV(gv) = compcv;
+	LEAVE;
+
+	GvCVGEN(gv) = 0;
+	sub_generation++;
+	CvGV(GvCV(gv)) = (GV*)SvREFCNT_inc(gv);
+	CvFILEGV(GvCV(gv)) = curcop->cop_filegv;
+	CvSTASH(GvCV(gv)) = curstash;
+#ifdef USE_THREADS
+	CvOWNER(GvCV(gv)) = 0;
+	New(666, CvMUTEXP(GvCV(gv)), 1, perl_mutex);
+	MUTEX_INIT(CvMUTEXP(GvCV(gv)));
+#endif /* USE_THREADS */
+	if (proto) {
+	    sv_setpv((SV*)GvCV(gv), proto);
+	    Safefree(proto);
+	}
+    }
 }
 
 static void
-gv_init_sv(gv, sv_type)
-GV* gv;
-I32 sv_type;
+gv_init_sv(GV *gv, I32 sv_type)
 {
     switch (sv_type) {
     case SVt_PVIO:
@@ -121,17 +150,12 @@ I32 sv_type;
 }
 
 GV *
-gv_fetchmeth(stash, name, len, level)
-HV* stash;
-char* name;
-STRLEN len;
-I32 level;
+gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level)
 {
     AV* av;
     GV* topgv;
     GV* gv;
     GV** gvp;
-    HV* lastchance;
     CV* cv;
 
     if (!stash)
@@ -159,10 +183,37 @@ I32 level;
 	}
     }
 
-    gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
-    if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+    av = (gvp && (gv = *gvp) && gv != (GV*)&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*)&sv_undef && (av = GvAV(gv))) {
+		dTHR;		/* just for SvREFCNT_dec */
+		gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
+		if (!gvp || !(gv = *gvp))
+		    croak("Cannot create %s::ISA", HvNAME(stash));
+		if (SvTYPE(gv) != SVt_PVGV)
+		    gv_init(gv, stash, "ISA", 3, TRUE);
+		SvREFCNT_dec(GvAV(gv));
+		GvAV(gv) = (AV*)SvREFCNT_inc(av);
+	    }
+	}
+    }
+
+    if (av) {
 	SV** svp = AvARRAY(av);
-	I32 items = AvFILL(av) + 1;
+	/* NOTE: No support for tied ISA */
+	I32 items = AvFILLp(av) + 1;
 	while (items--) {
 	    SV* sv = *svp++;
 	    HV* basestash = gv_stashsv(sv, FALSE);
@@ -179,13 +230,25 @@ I32 level;
 	}
     }
 
+    /* if at top level, try UNIVERSAL */
+
     if (level == 0 || level == -1) {
+	HV* lastchance;
+
 	if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
 	    if (gv = gv_fetchmeth(lastchance, name, len,
 				  (level >= 0) ? level + 1 : level - 1)) {
 	  gotcha:
-		/* Use topgv for cache only if it has no synonyms */
-		if (topgv && GvREFCNT(topgv) == 1) {
+		/*
+		 * 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));
@@ -200,91 +263,74 @@ I32 level;
 }
 
 GV *
-gv_fetchmethod(stash, name)
-HV* stash;
-char* name;
+gv_fetchmethod(HV *stash, char *name)
+{
+    return gv_fetchmethod_autoload(stash, name, TRUE);
+}
+
+GV *
+gv_fetchmethod_autoload(HV *stash, char *name, I32 autoload)
 {
+    dTHR;
     register char *nend;
     char *nsplit = 0;
     GV* gv;
     
     for (nend = name; *nend; nend++) {
-	if (*nend == ':' || *nend == '\'')
+	if (*nend == '\'')
 	    nsplit = nend;
+	else if (*nend == ':' && *(nend + 1) == ':')
+	    nsplit = ++nend;
     }
     if (nsplit) {
-	char ch;
 	char *origname = name;
 	name = nsplit + 1;
-	ch = *nsplit;
 	if (*nsplit == ':')
 	    --nsplit;
-	*nsplit = '\0';
-	if (strEQ(origname,"SUPER")) {
-	    /* Degenerate case ->SUPER::method should really lookup in original stash */
-	    SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
-	    sv_catpvn(tmpstr, "::SUPER", 7);
-	    stash = gv_stashpvn(SvPVX(tmpstr),SvCUR(tmpstr),TRUE);
-	    *nsplit = ch;
-	    DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
-	} else {
-	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
-	    *nsplit = ch;
+	if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
+	    /* ->SUPER::method should really be looked up in original stash */
+	    SV *tmpstr = sv_2mortal(newSVpvf("%s::SUPER",
+					     HvNAME(curcop->cop_stash)));
+	    stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE);
+	    DEBUG_o( deb("Treating %s as %s::%s\n",
+			 origname, HvNAME(stash), name) );
 	}
-    }
-    gv = gv_fetchmeth(stash, name, nend - name, 0);
-
-    if (!gv) {
-	/* Failed obvious case - look for SUPER as last element of stash's name */
-	char *packname = HvNAME(stash);
-	STRLEN len     = strlen(packname);
-	if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
-	    /* Now look for @.*::SUPER::ISA */
-	    GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
-	    len -= 7;
-	    if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
-		/* No @ISA in package ending in ::SUPER - drop suffix
-		   and see if there is an @ISA there
-		 */
-		HV *basestash;
-		char ch = packname[len];
-		AV *av;
-		packname[len] = '\0';
-		basestash = gv_stashpvn(packname, len, TRUE);
-		packname[len] = ch;
-		gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
-		if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
-		     /* Okay found @ISA after dropping the SUPER, alias it */
-	             SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
-	             sv_catpvn(tmpstr, "::ISA", 5);
-		     gv  = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV);
-                     if (gv) {
-			GvAV(gv) = (AV*)SvREFCNT_inc(av);
-			/* ... and re-try lookup */
-			gv = gv_fetchmeth(stash, name, nend - name, 0);
-		     } else {
-			croak("Cannot create %s::ISA",HvNAME(stash));
-		     }
-		}
-	    }
-	}     
+	else
+	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
     }
 
+    gv = gv_fetchmeth(stash, name, nend - name, 0);
     if (!gv) {
 	if (strEQ(name,"import"))
 	    gv = (GV*)&sv_yes;
-	else
-	    gv = gv_autoload(stash, name, nend - name);
+	else if (autoload)
+	    gv = gv_autoload4(stash, name, nend - name, TRUE);
+    }
+    else if (autoload) {
+	CV* cv = GvCV(gv);
+	if (!CvROOT(cv) && !CvXSUB(cv)) {
+	    GV* stubgv;
+	    GV* autogv;
+
+	    if (CvANON(cv))
+		stubgv = gv;
+	    else {
+		stubgv = CvGV(cv);
+		if (GvCV(stubgv) != cv)		/* orphaned import */
+		    stubgv = gv;
+	    }
+	    autogv = gv_autoload4(GvSTASH(stubgv),
+				  GvNAME(stubgv), GvNAMELEN(stubgv), TRUE);
+	    if (autogv)
+		gv = autogv;
+	}
     }
 
     return gv;
 }
 
 GV*
-gv_autoload(stash, name, len)
-HV* stash;
-char* name;
-STRLEN len;
+gv_autoload4(HV *stash, char *name, STRLEN len, I32 method)
 {
     static char autoload[] = "AUTOLOAD";
     static STRLEN autolen = 8;
@@ -296,11 +342,19 @@ STRLEN len;
 
     if (len == autolen && strnEQ(name, autoload, autolen))
 	return Nullgv;
-    if (!(gv = gv_fetchmeth(stash, autoload, autolen, 0)))
+    if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
 	return Nullgv;
     cv = GvCV(gv);
 
     /*
+     * Inheriting AUTOLOAD for non-methods works ... for now.
+     */
+    if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
+	warn(
+	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
+	     HvNAME(stash), (int)len, name);
+
+    /*
      * Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
      * The subroutine's original name may not be "AUTOLOAD", so we don't
      * use that, but for lack of anything better we will use the sub's
@@ -319,36 +373,30 @@ STRLEN len;
 }
 
 HV*
-gv_stashpv(name,create)
-char *name;
-I32 create;
+gv_stashpv(char *name, I32 create)
 {
     return gv_stashpvn(name, strlen(name), create);
 }
 
 HV*
-gv_stashpvn(name,namelen,create)
-char *name;
-U32 namelen;
-I32 create;
+gv_stashpvn(char *name, U32 namelen, I32 create)
 {
-    char tmpbuf[1203];
+    char smallbuf[256];
+    char *tmpbuf;
     HV *stash;
     GV *tmpgv;
 
-    if (namelen > 1200) {
-	namelen = 1200;
-#ifdef VMS
-	warn("Weird package name \"%s\" truncated", name);
-#else
-	warn("Weird package name \"%.*s...\" truncated", namelen, name);
-#endif
-    }
+    if (namelen + 3 < sizeof smallbuf)
+	tmpbuf = smallbuf;
+    else
+	New(606, tmpbuf, namelen + 3, char);
     Copy(name,tmpbuf,namelen,char);
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen++] = ':';
     tmpbuf[namelen] = '\0';
-    tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
+    tmpgv = gv_fetchpv(tmpbuf, create, SVt_PVHV);
+    if (tmpbuf != smallbuf)
+	Safefree(tmpbuf);
     if (!tmpgv)
 	return 0;
     if (!GvHV(tmpgv))
@@ -360,9 +408,7 @@ I32 create;
 }
 
 HV*
-gv_stashsv(sv,create)
-SV *sv;
-I32 create;
+gv_stashsv(SV *sv, I32 create)
 {
     register char *ptr;
     STRLEN len;
@@ -372,19 +418,16 @@ I32 create;
 
 
 GV *
-gv_fetchpv(nambeg,add,sv_type)
-char *nambeg;
-I32 add;
-I32 sv_type;
+gv_fetchpv(char *nambeg, I32 add, I32 sv_type)
 {
+    dTHR;
     register char *name = nambeg;
     register GV *gv = 0;
     GV**gvp;
     I32 len;
     register char *namend;
     HV *stash = 0;
-    bool global = FALSE;
-    char *tmpbuf;
+    U32 add_gvflags = 0;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
 	name++;
@@ -400,23 +443,29 @@ I32 sv_type;
 
 	    len = namend - name;
 	    if (len > 0) {
-		New(601, tmpbuf, len+3, char);
+		char *tmpbuf;
+		char autobuf[64];
+
+		if (len < sizeof(autobuf) - 2)
+		    tmpbuf = autobuf;
+		else
+		    New(601, tmpbuf, len+3, char);
 		Copy(name, tmpbuf, len, char);
 		tmpbuf[len++] = ':';
 		tmpbuf[len++] = ':';
 		tmpbuf[len] = '\0';
 		gvp = (GV**)hv_fetch(stash,tmpbuf,len,add);
-		Safefree(tmpbuf);
-		if (!gvp || *gvp == (GV*)&sv_undef)
-		    return Nullgv;
-		gv = *gvp;
-
-		if (SvTYPE(gv) == SVt_PVGV)
-		    GvMULTI_on(gv);
-		else if (!add)
+		gv = gvp ? *gvp : Nullgv;
+		if (gv && gv != (GV*)&sv_undef) {
+		    if (SvTYPE(gv) != SVt_PVGV)
+			gv_init(gv, stash, tmpbuf, len, (add & 2));
+		    else
+			GvMULTI_on(gv);
+		}
+		if (tmpbuf != autobuf)
+		    Safefree(tmpbuf);
+		if (!gv || gv == (GV*)&sv_undef)
 		    return Nullgv;
-		else
-		    gv_init(gv, stash, nambeg, namend - nambeg, (add & 2));
 
 		if (!(stash = GvHV(gv)))
 		    stash = GvHV(gv) = newHV();
@@ -441,6 +490,8 @@ I32 sv_type;
 
     if (!stash) {
 	if (isIDFIRST(*name)) {
+	    bool global = FALSE;
+
 	    if (isUPPER(*name)) {
 		if (*name > 'I') {
 		    if (*name == 'S' && (
@@ -465,6 +516,7 @@ I32 sv_type;
 	    }
 	    else if (*name == '_' && !name[1])
 		global = TRUE;
+
 	    if (global)
 		stash = defstash;
 	    else if ((COP*)curcop == &compiling) {
@@ -507,13 +559,26 @@ I32 sv_type;
     /* By this point we should have a stash and a name */
 
     if (!stash) {
-	if (add) {
-	    warn("Global symbol \"%s\" requires explicit package name", name);
-	    ++error_count;
-	    stash = curstash ? curstash : defstash;	/* avoid core dumps */
-	}
-	else
+	if (!add)
 	    return Nullgv;
+	if (add & ~2) {
+	    char sv_type_char = ((sv_type == SVt_PV) ? '$'
+				 : (sv_type == SVt_PVAV) ? '@'
+				 : (sv_type == SVt_PVHV) ? '%'
+				 : 0);
+	    if (sv_type_char) 
+		warn("Global symbol \"%c%s\" requires explicit package name",
+		     sv_type_char, name);
+	    else
+		warn("Global symbol \"%s\" requires explicit package name",
+		     name);
+	}
+	++error_count;
+	stash = curstash ? curstash : defstash;	/* avoid core dumps */
+	add_gvflags = ((sv_type == SVt_PV) ? GVf_IMPORTED_SV
+		       : (sv_type == SVt_PVAV) ? GVf_IMPORTED_AV
+		       : (sv_type == SVt_PVHV) ? GVf_IMPORTED_HV
+		       : 0);
     }
 
     if (!SvREFCNT(stash))	/* symbol table under destruction */
@@ -529,14 +594,17 @@ I32 sv_type;
 	    gv_init_sv(gv, sv_type);
 	}
 	return gv;
+    } else if (add & GV_NOINIT) {
+	return gv;
     }
 
     /* Adding a new symbol */
 
-    if (add & 4)
+    if (add & GV_ADDWARN)
 	warn("Had to create %s unexpectedly", nambeg);
-    gv_init(gv, stash, name, len, add & 2);
+    gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, sv_type);
+    GvFLAGS(gv) |= add_gvflags;
 
     /* set up magic where warranted */
     switch (*name) {
@@ -560,7 +628,9 @@ I32 sv_type;
 	    AV* av = GvAVn(gv);
 	    GvMULTI_on(gv);
 	    sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
-	    if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
+	    /* NOTE: No support for tied ISA */
+	    if ((add & GV_ADDMULTI) && strEQ(nambeg,"AnyDBM_File::ISA")
+		&& AvFILLp(av) == -1)
 	    {
 		char *pname;
 		av_push(av, newSVpv(pname = "NDBM_File",0));
@@ -581,7 +651,7 @@ I32 sv_type;
         if (strEQ(name, "OVERLOAD")) {
             HV* hv = GvHVn(gv);
             GvMULTI_on(gv);
-            sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
+            hv_magic(hv, gv, 'A');
         }
         break;
 #endif /* OVERLOAD */
@@ -601,11 +671,6 @@ I32 sv_type;
 	    	psig_ptr[i] = 0;
 	    	psig_name[i] = 0;
 	    }
-	    /* initialize signal stack */
-	    signalstack = newAV();
-	    AvREAL_off(signalstack);
-	    av_extend(signalstack, 30);
-	    av_fill(signalstack, 0);
 	}
 	break;
 
@@ -636,14 +701,36 @@ I32 sv_type;
 	sv_setpv(GvSV(gv),chopset);
 	goto magicalize;
 
+    case '?':
+	if (len > 1)
+	    break;
+#ifdef COMPLEX_STATUS
+	sv_upgrade(GvSV(gv), SVt_PVLV);
+#endif
+	goto magicalize;
+
+    case '!':
+	if(len > 1)
+	    break;
+	if(sv_type > SVt_PV) {
+	    HV* stash = gv_stashpvn("Errno",5,FALSE);
+	    if(!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+		dSP;
+		PUTBACK;
+		perl_require_pv("Errno.pm");
+		SPAGAIN;
+		stash = gv_stashpvn("Errno",5,FALSE);
+		if (!stash || !(gv_fetchmethod(stash, "TIEHASH")))
+		    croak("Can't use %%! because Errno.pm is not avaliable");
+	    }
+	}
+	goto magicalize;
     case '#':
     case '*':
 	if (dowarn && len == 1 && sv_type == SVt_PV)
 	    warn("Use of $%s is deprecated", name);
 	/* FALL THROUGH */
     case '[':
-    case '!':
-    case '?':
     case '^':
     case '~':
     case '=':
@@ -666,7 +753,6 @@ I32 sv_type;
     case '\017':
     case '\t':
     case '\020':
-    case '\023':
     case '\024':
     case '\027':
 	if (len > 1)
@@ -683,6 +769,7 @@ I32 sv_type;
     case '7':
     case '8':
     case '9':
+    case '\023':
       ro_magicalize:
 	SvREADONLY_on(GvSV(gv));
       magicalize:
@@ -714,10 +801,7 @@ I32 sv_type;
 }
 
 void
-gv_fullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_fullname3(SV *sv, GV *gv, char *prefix)
 {
     HV *hv = GvSTASH(gv);
     if (!hv) {
@@ -731,10 +815,7 @@ char *prefix;
 }
 
 void
-gv_efullname3(sv, gv, prefix)
-SV *sv;
-GV *gv;
-char *prefix;
+gv_efullname3(SV *sv, GV *gv, char *prefix)
 {
     GV *egv = GvEGV(gv);
     if (!egv)
@@ -744,25 +825,22 @@ char *prefix;
 
 /* XXX compatibility with versions <= 5.003. */
 void
-gv_fullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_fullname(SV *sv, GV *gv)
 {
     gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 }
 
 /* XXX compatibility with versions <= 5.003. */
 void
-gv_efullname(sv,gv)
-SV *sv;
-GV *gv;
+gv_efullname(SV *sv, GV *gv)
 {
     gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 }
 
 IO *
-newIO()
+newIO(void)
 {
+    dTHR;
     IO *io;
     GV *iogv;
 
@@ -770,15 +848,17 @@ newIO()
     sv_upgrade((SV *)io,SVt_PVIO);
     SvREFCNT(io) = 1;
     SvOBJECT_on(io);
-    iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
+    iogv = gv_fetchpv("FileHandle::", FALSE, SVt_PVHV);
+    if (!iogv)
+      iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
     SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
     return io;
 }
 
 void
-gv_check(stash)
-HV* stash;
+gv_check(HV *stash)
 {
+    dTHR;
     register HE *entry;
     register I32 i;
     register GV *gv;
@@ -797,7 +877,7 @@ HV* stash;
 	    }
 	    else if (isALPHA(*HeKEY(entry))) {
 		gv = (GV*)HeVAL(entry);
-		if (GvMULTI(gv))
+		if (SvTYPE(gv) != SVt_PVGV || GvMULTI(gv))
 		    continue;
 		curcop->cop_line = GvLINE(gv);
 		filegv = GvFILEGV(gv);
@@ -812,18 +892,16 @@ HV* stash;
 }
 
 GV *
-newGVgen(pack)
-char *pack;
+newGVgen(char *pack)
 {
-    (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
-    return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
+    return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+		      TRUE, SVt_PVGV);
 }
 
 /* hopefully this is only called on local symbol table entries */
 
 GP*
-gp_ref(gp)
-GP* gp;
+gp_ref(GP *gp)
 {
     gp->gp_refcnt++;
     if (gp->gp_cv) {
@@ -842,8 +920,7 @@ GP* gp;
 }
 
 void
-gp_free(gv)
-GV* gv;
+gp_free(GV *gv)
 {
     GP* gp;
     CV* cv;
@@ -903,15 +980,15 @@ register GV *gv;
 /* Updates and caches the CV's */
 
 bool
-Gv_AMupdate(stash)
-HV* stash;
+Gv_AMupdate(HV *stash)
 {
+  dTHR;  
   GV** gvp;
   HV* hv;
   GV* gv;
   CV* cv;
   MAGIC* mg=mg_find((SV*)stash,'c');
-  AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+  AMT *amtp = (mg) ? (AMT*)mg->mg_ptr: (AMT *) NULL;
   AMT amt;
 
   if (mg && amtp->was_ok_am == amagic_generation
@@ -991,13 +1068,13 @@ HV* stash;
   {
     int filled = 0;
     int i;
-    char *cp;
+    const char *cp;
     SV* sv = NULL;
     SV** svp;
 
     /* Work with "fallback" key, which we assume to be first in AMG_names */
 
-    if ( cp = (char *)AMG_names[0] ) {
+    if ( cp = AMG_names[0] ) {
 	/* Try to find via inheritance. */
 	gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
 	if (gv) sv = GvSV(gv);
@@ -1008,16 +1085,13 @@ HV* stash;
     }
 
     for (i = 1; i < NofAMmeth; i++) {
-        cv = 0;
-        cp = (char *)AMG_names[i];
-      
-	*buf = '(';			/* A cookie: "(". */
-	strcpy(buf + 1, cp);
+	SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
 	DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
 		     cp, HvNAME(stash)) );
-	gv = gv_fetchmeth(stash, buf, strlen(buf), -1); /* no filling stash! */
+	/* don't fill the cache while looking up! */
+	gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+        cv = 0;
         if(gv && (cv = GvCV(gv))) {
-	    char *name = buf;
 	    if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
 		&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
 		/* GvSV contains the name of the method. */
@@ -1025,11 +1099,10 @@ HV* stash;
 		
 		DEBUG_o( deb("Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n", 
 			     SvPV(GvSV(gv), na), cp, HvNAME(stash)) );
-		if (SvPOK(GvSV(gv)) 
-		    && (ngv = gv_fetchmethod(stash, SvPVX(GvSV(gv))))) {
-		    name = SvPVX(GvSV(gv));
-		    cv = GvCV(gv = ngv);
-		} else {
+		if (!SvPOK(GvSV(gv)) 
+		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
+						       FALSE)))
+		{
 		    /* Can be an import stub (created by `can'). */
 		    if (GvCVGEN(gv)) {
 			croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", 
@@ -1040,9 +1113,7 @@ HV* stash;
 			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
 			      cp, HvNAME(stash));
 		}
-	        /* If the sub is only a stub then we may have a gv to AUTOLOAD */
-	        gv = (GV*)*hv_fetch(GvSTASH(gv), name, strlen(name), TRUE);
-	        cv = GvCV(gv);
+		cv = GvCV(gv = ngv);
 	    }
 	    DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
 			 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
@@ -1065,16 +1136,10 @@ HV* stash;
   return FALSE;
 }
 
-/* During call to this subroutine stack can be reallocated. It is
- * advised to call SPAGAIN macro in your code after call */
-
 SV*
-amagic_call(left,right,method,flags)
-SV* left;
-SV* right;
-int method;
-int flags; 
+amagic_call(SV *left, SV *right, int method, int flags)
 {
+  dTHR;
   MAGIC *mg; 
   CV *cv; 
   CV **cvp=NULL, **ocvp=NULL;
@@ -1086,7 +1151,7 @@ int flags;
       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
 			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
-			: NULL))
+			: (CV **) NULL))
       && ((cv = cvp[off=method+assignshift]) 
 	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
 						          * usual method */
@@ -1128,13 +1193,11 @@ int flags;
 	 case copy_amg:
 	   {
 	     SV* ref=SvRV(left);
-	     if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
-						      * extra
-						      * causious,
-						      * maybe in some
-						      * additional
-						      * cases sv_setsv
-						      * is safe too */
+	     if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+		/*
+		 * Just to be extra cautious.  Maybe in some
+		 * additional cases sv_setsv is safe, too.
+		 */
 		SV* newref = newSVsv(ref);
 		SvOBJECT_on(newref);
 		SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
@@ -1181,7 +1244,7 @@ int flags;
 	       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
 	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
 			  ? (amtp = (AMT*)mg->mg_ptr)->table
-			  : NULL))
+			  : (CV **) NULL))
 	       && (cv = cvp[off=method])) { /* Method for right
 					     * argument found */
       lr=1;
@@ -1191,7 +1254,7 @@ int flags;
 	       && !(flags & AMGf_unary)) {
 				/* We look for substitution for
 				 * comparison operations and
-				 * concatendation */
+				 * concatenation */
       if (method==concat_amg || method==concat_ass_amg
 	  || method==repeat_amg || method==repeat_ass_amg) {
 	return NULL;		/* Delegate operation to string conversion */
@@ -1224,9 +1287,10 @@ int flags;
       } else if (cvp && (cv=cvp[nomethod_amg])) {
 	notfound = 1; lr = 1;
       } else {
+	SV *msg;
 	if (off==-1) off=method;
-	sprintf(buf,
-		"Operation `%s': no method found,%sargument %s%.256s%s%.256s",
+	msg = sv_2mortal(newSVpvf(
+		      "Operation `%s': no method found,%sargument %s%s%s%s",
 		      AMG_names[method + assignshift],
 		      (flags & AMGf_unary ? " " : "\n\tleft "),
 		      SvAMAGIC(left)? 
@@ -1242,11 +1306,11 @@ int flags;
 			 : ",\n\tright argument has no overloaded magic"),
 		      SvAMAGIC(right)? 
 		        HvNAME(SvSTASH(SvRV(right))):
-		        "");
+		        ""));
 	if (amtp && amtp->fallback >= AMGfallYES) {
-	  DEBUG_o( deb(buf) );
+	  DEBUG_o( deb("%s", SvPVX(msg)) );
 	} else {
-	  croak(buf);
+	  croak("%_", msg);
 	}
 	return NULL;
       }
@@ -1254,7 +1318,7 @@ int flags;
   }
   if (!notfound) {
     DEBUG_o( deb(
-  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
+  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
 		 AMG_names[off],
 		 method+assignshift==off? "" :
 		             " (initially `",
@@ -1278,42 +1342,41 @@ int flags;
     dSP;
     BINOP myop;
     SV* res;
+    bool oldcatch = CATCH_GET;
 
+    CATCH_SET(TRUE);
     Zero(&myop, 1, BINOP);
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
-    myop.op_flags = OPf_KNOW|OPf_STACKED;
+    myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
 
+    PUSHSTACK(SI_OVERLOAD);
     ENTER;
-    SAVESPTR(op);
+    SAVEOP();
     op = (OP *) &myop;
-    if (perldb && curstash != debstash)
+    if (PERLDB_SUB && curstash != debstash)
 	op->op_private |= OPpENTERSUB_DB;
     PUTBACK;
-    pp_pushmark();
+    pp_pushmark(ARGS);
 
-    EXTEND(sp, notfound + 5);
+    EXTEND(SP, notfound + 5);
     PUSHs(lr>0? right: left);
     PUSHs(lr>0? left: right);
-    PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
+    PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
     if (notfound) {
       PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
     }
     PUSHs((SV*)cv);
     PUTBACK;
 
-    if (op = pp_entersub())
+    if (op = pp_entersub(ARGS))
       runops();
     LEAVE;
     SPAGAIN;
 
     res=POPs;
-    PUTBACK;
-
-    if (notfound) {
-      /* sv_2mortal(res); */
-      return NULL;
-    }
+    POPSTACK();
+    CATCH_SET(oldcatch);
 
     if (postpr) {
       int ans;
@@ -1342,7 +1405,7 @@ int flags;
       case not_amg:
 	ans=!SvOK(res); break;
       }
-      return ans? &sv_yes: &sv_no;
+      return boolSV(ans);
     } else if (method==copy_amg) {
       if (!SvROK(res)) {
 	croak("Copy method did not return a reference");
@@ -1354,3 +1417,4 @@ int flags;
   }
 }
 #endif /* OVERLOAD */
+