X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=665825963f461f06b29a443563aacded4b5e6e3e;hb=8490252049bf42d3d2f75d89178a8682bf22ba74;hp=5b61bcc42f0ac3e4dbbfb4724c47f2363e93ca71;hpb=c07a80fdfe3926b5eb0585b674aa5d1f57b32ade;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 5b61bcc..6658259 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.
@@ -19,7 +19,7 @@
 #include "EXTERN.h"
 #include "perl.h"
 
-extern char rcsid[];
+EXT char rcsid[];
 
 GV *
 gv_AVadd(gv)
@@ -58,15 +58,28 @@ GV *
 gv_fetchfile(name)
 char *name;
 {
-    char tmpbuf[1200];
+    char smallbuf[256];
+    char *tmpbuf;
+    STRLEN tmplen;
     GV *gv;
 
-    sprintf(tmpbuf,"::_<%s", name);
-    gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
+    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")))
-	SvMULTI_on(gv);
-    if (perldb)
+    if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
+	GvMULTI_on(gv);
+    if (PERLDB_LINE)
 	hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
     return gv;
 }
@@ -81,12 +94,11 @@ int multi;
 {
     register GP *gp;
 
-    sv_upgrade(gv, SVt_PVGV);
+    sv_upgrade((SV*)gv, SVt_PVGV);
     if (SvLEN(gv))
 	Safefree(SvPVX(gv));
-    Newz(602,gp, 1, GP);
+    Newz(602, gp, 1, GP);
     GvGP(gv) = gp_ref(gp);
-    GvREFCNT(gv) = 1;
     GvSV(gv) = NEWSV(72,0);
     GvLINE(gv) = curcop->cop_line;
     GvFILEGV(gv) = curcop->cop_filegv;
@@ -96,7 +108,7 @@ int multi;
     GvNAME(gv) = savepvn(name, len);
     GvNAMELEN(gv) = len;
     if (multi)
-	SvMULTI_on(gv);
+	GvMULTI_on(gv);
 }
 
 static void
@@ -128,37 +140,60 @@ I32 level;
     GV* topgv;
     GV* gv;
     GV** gvp;
-    HV* lastchance;
     CV* cv;
 
     if (!stash)
 	return 0;
-    if (level > 100)
+    if ((level > 100) || (level < -100))
 	croak("Recursive inheritance detected");
 
-    gvp = (GV**)hv_fetch(stash, name, len, TRUE);
-
     DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
-    topgv = *gvp;
-    if (SvTYPE(topgv) != SVt_PVGV)
-	gv_init(topgv, stash, name, len, TRUE);
-
-    if (cv=GvCV(topgv)) {
-	if (GvCVGEN(topgv) >= sub_generation)
-	    return topgv;	/* valid cached inheritance */
-	if (!GvCVGEN(topgv)) {	/* not an inheritance cache */
-	    return topgv;
-	}
-	else {
-	    /* stale cached entry, just junk it */
-	    GvCV(topgv) = cv = 0;
+
+    gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
+    if (!gvp)
+	topgv = Nullgv;
+    else {
+	topgv = *gvp;
+	if (SvTYPE(topgv) != SVt_PVGV)
+	    gv_init(topgv, stash, name, len, TRUE);
+	if (cv = GvCV(topgv)) {
+	    /* If genuine method or valid cache entry, use it */
+	    if (!GvCVGEN(topgv) || GvCVGEN(topgv) >= sub_generation)
+		return topgv;
+	    /* Stale cached entry: junk it */
+	    SvREFCNT_dec(cv);
+	    GvCV(topgv) = cv = Nullcv;
 	    GvCVGEN(topgv) = 0;
 	}
     }
-    /* if cv is still set, we have to free it if we find something to cache */
 
-    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 @.*::SUPER::ISA on demand */
+    if (!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))) {
+		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;
 	while (items--) {
@@ -170,30 +205,37 @@ I32 level;
 			SvPVX(sv), HvNAME(stash));
 		continue;
 	    }
-	    gv = gv_fetchmeth(basestash, name, len, level + 1);
-	    if (gv) {
-		if (cv) {				/* junk old undef */
-		    assert(SvREFCNT(topgv) > 1);
-		    SvREFCNT_dec(topgv);
-		    SvREFCNT_dec(cv);
-		}
-		GvCV(topgv) = GvCV(gv);			/* cache the CV */
-		GvCVGEN(topgv) = sub_generation;	/* valid for now */
-		return gv;
-	    }
+	    gv = gv_fetchmeth(basestash, name, len,
+			      (level >= 0) ? level + 1 : level - 1);
+	    if (gv)
+		goto gotcha;
 	}
     }
 
-    if (!level) {
-	if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
-	    if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
-		if (cv) {				/* junk old undef */
-		    assert(SvREFCNT(topgv) > 1);
-		    SvREFCNT_dec(topgv);
-		    SvREFCNT_dec(cv);
+    /* 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:
+		/*
+		 * Cache method in topgv if:
+		 *  1. topgv has no synonyms (else inheritance crosses wires)
+		 *  2. method isn't a stub (else AUTOLOAD fails spectacularly)
+		 */
+		if (topgv &&
+		    GvREFCNT(topgv) == 1 &&
+		    (cv = GvCV(gv)) &&
+		    (CvROOT(cv) || CvXSUB(cv)))
+		{
+		    if (cv = GvCV(topgv))
+			SvREFCNT_dec(cv);
+		    GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
+		    GvCVGEN(topgv) = sub_generation;
 		}
-		GvCV(topgv) = GvCV(gv);			/* cache the CV */
-		GvCVGEN(topgv) = sub_generation;	/* valid for now */
 		return gv;
 	    }
 	}
@@ -207,88 +249,116 @@ gv_fetchmethod(stash, name)
 HV* stash;
 char* name;
 {
+    return gv_fetchmethod_autoload(stash, name, TRUE);
+}
+
+GV *
+gv_fetchmethod_autoload(stash, name, autoload)
+HV* stash;
+char* name;
+I32 autoload;
+{
     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_stashpv(SvPV(tmpstr,na),TRUE);
-	    *nsplit = ch;
-	    DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
-	} else {
-	    stash = gv_stashpv(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) );
 	}
+	else
+	    stash = gv_stashpvn(origname, nsplit - origname, TRUE);
     }
-    gv = gv_fetchmeth(stash, name, nend - name, 0);
 
+    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);
-	    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-7];
-		AV *av;
-		packname[len-7] = '\0';
-		basestash = gv_stashpv(packname, TRUE);
-		packname[len-7] = 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));
-		     }
-		}
-	    }
-	}     
+	if (strEQ(name,"import"))
+	    gv = (GV*)&sv_yes;
+	else if (autoload)
+	    gv = gv_autoload4(stash, name, nend - name, TRUE);
     }
-
-    if (!gv) {
-	CV* cv;
-
-	if (strEQ(name,"import") || strEQ(name,"unimport"))
-	    gv = &sv_yes;
-	else if (strNE(name, "AUTOLOAD")) {
-	    gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
-	    if (gv && (cv = GvCV(gv))) { /* One more chance... */
-		SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
-		sv_catpvn(tmpstr,"::", 2);
-		sv_catpvn(tmpstr, name, nend - name);
-		sv_setsv(GvSV(CvGV(cv)), tmpstr);
-		if (tainting)
-		    sv_unmagic(GvSV(CvGV(cv)), 't');
+    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_autoload4(stash, name, len, method)
+HV* stash;
+char* name;
+STRLEN len;
+I32 method;
+{
+    static char autoload[] = "AUTOLOAD";
+    static STRLEN autolen = 8;
+    GV* gv;
+    CV* cv;
+    HV* varstash;
+    GV* vargv;
+    SV* varsv;
+
+    if (len == autolen && strnEQ(name, autoload, autolen))
+	return Nullgv;
+    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
+     * original package to look up $AUTOLOAD.
+     */
+    varstash = GvSTASH(CvGV(cv));
+    vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
+    if (!isGV(vargv))
+	gv_init(vargv, varstash, autoload, autolen, FALSE);
+    varsv = GvSV(vargv);
+    sv_setpv(varsv, HvNAME(stash));
+    sv_catpvn(varsv, "::", 2);
+    sv_catpvn(varsv, name, len);
+    SvTAINTED_off(varsv);
     return gv;
 }
 
@@ -297,15 +367,31 @@ gv_stashpv(name,create)
 char *name;
 I32 create;
 {
-    char tmpbuf[1234];
+    return gv_stashpvn(name, strlen(name), create);
+}
+
+HV*
+gv_stashpvn(name,namelen,create)
+char *name;
+U32 namelen;
+I32 create;
+{
+    char smallbuf[256];
+    char *tmpbuf;
     HV *stash;
     GV *tmpgv;
-    /* Use strncpy to avoid bug in VMS sprintf */
-    /* sprintf(tmpbuf,"%.*s::",1200,name); */
-    strncpy(tmpbuf, name, 1200);
-    tmpbuf[1200] = '\0';  /* just in case . . . */
-    strcat(tmpbuf, "::");
-    tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
+
+    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);
+    if (tmpbuf != smallbuf)
+	Safefree(tmpbuf);
     if (!tmpgv)
 	return 0;
     if (!GvHV(tmpgv))
@@ -321,7 +407,10 @@ gv_stashsv(sv,create)
 SV *sv;
 I32 create;
 {
-    return gv_stashpv(SvPV(sv,na), create);
+    register char *ptr;
+    STRLEN len;
+    ptr = SvPV(sv,len);
+    return gv_stashpvn(ptr, len, create);
 }
 
 
@@ -337,7 +426,7 @@ I32 sv_type;
     I32 len;
     register char *namend;
     HV *stash = 0;
-    bool global = FALSE;
+    U32 add_gvflags = 0;
     char *tmpbuf;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
@@ -349,7 +438,7 @@ I32 sv_type;
 	{
 	    if (!stash)
 		stash = defstash;
-	    if (!SvREFCNT(stash))	/* symbol table under destruction */
+	    if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
 		return Nullgv;
 
 	    len = namend - name;
@@ -366,7 +455,7 @@ I32 sv_type;
 		gv = *gvp;
 
 		if (SvTYPE(gv) == SVt_PVGV)
-		    SvMULTI_on(gv);
+		    GvMULTI_on(gv);
 		else if (!add)
 		    return Nullgv;
 		else
@@ -384,7 +473,7 @@ I32 sv_type;
 	    namend++;
 	    name = namend;
 	    if (!*name)
-		return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
+		return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
 	}
     }
     len = namend - name;
@@ -395,6 +484,8 @@ I32 sv_type;
 
     if (!stash) {
 	if (isIDFIRST(*name)) {
+	    bool global = FALSE;
+
 	    if (isUPPER(*name)) {
 		if (*name > 'I') {
 		    if (*name == 'S' && (
@@ -419,6 +510,7 @@ I32 sv_type;
 	    }
 	    else if (*name == '_' && !name[1])
 		global = TRUE;
+
 	    if (global)
 		stash = defstash;
 	    else if ((COP*)curcop == &compiling) {
@@ -428,23 +520,24 @@ I32 sv_type;
 		    sv_type != SVt_PVGV &&
 		    sv_type != SVt_PVFM &&
 		    sv_type != SVt_PVIO &&
-		    !(len == 1 && sv_type == SVt_PV && index("ab",*name)) )
+		    !(len == 1 && sv_type == SVt_PV && strchr("ab",*name)) )
 		{
 		    gvp = (GV**)hv_fetch(stash,name,len,0);
 		    if (!gvp ||
-			    *gvp == (GV*)&sv_undef ||
-			    SvTYPE(*gvp) != SVt_PVGV ||
-			    !(GvFLAGS(*gvp) & GVf_IMPORTED))
+			*gvp == (GV*)&sv_undef ||
+			SvTYPE(*gvp) != SVt_PVGV)
+		    {
 			stash = 0;
-		    else if (sv_type == SVt_PVAV && !GvAV(*gvp) ||
-			     sv_type == SVt_PVHV && !GvHV(*gvp) ||
-			     sv_type == SVt_PV   && !GvSV(*gvp) )
+		    }
+		    else if (sv_type == SVt_PV   && !GvIMPORTED_SV(*gvp) ||
+			     sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp) ||
+			     sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp) )
 		    {
-			warn("Variable \"%c%s\" is not exported",
+			warn("Variable \"%c%s\" is not imported",
 			    sv_type == SVt_PVAV ? '@' :
 			    sv_type == SVt_PVHV ? '%' : '$',
 			    name);
-			if (GvCV(*gvp))
+			if (GvCVu(*gvp))
 			    warn("(Did you mean &%s instead?)\n", name);
 			stash = 0;
 		    }
@@ -464,6 +557,10 @@ I32 sv_type;
 	    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);
 	}
 	else
 	    return Nullgv;
@@ -478,7 +575,7 @@ I32 sv_type;
     gv = *gvp;
     if (SvTYPE(gv) == SVt_PVGV) {
 	if (add) {
-	    SvMULTI_on(gv);
+	    GvMULTI_on(gv);
 	    gv_init_sv(gv, sv_type);
 	}
 	return gv;
@@ -490,6 +587,7 @@ I32 sv_type;
 	warn("Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & 2);
     gv_init_sv(gv, sv_type);
+    GvFLAGS(gv) |= add_gvflags;
 
     /* set up magic where warranted */
     switch (*name) {
@@ -502,30 +600,30 @@ I32 sv_type;
     case 'a':
     case 'b':
 	if (len == 1)
-	    SvMULTI_on(gv);
+	    GvMULTI_on(gv);
 	break;
     case 'E':
 	if (strnEQ(name, "EXPORT", 6))
-	    SvMULTI_on(gv);
+	    GvMULTI_on(gv);
 	break;
     case 'I':
 	if (strEQ(name, "ISA")) {
 	    AV* av = GvAVn(gv);
-	    SvMULTI_on(gv);
+	    GvMULTI_on(gv);
 	    sv_magic((SV*)av, (SV*)gv, 'I', Nullch, 0);
 	    if (add & 2 && strEQ(nambeg,"AnyDBM_File::ISA") && AvFILL(av) == -1)
 	    {
 		char *pname;
 		av_push(av, newSVpv(pname = "NDBM_File",0));
-		gv_stashpv(pname, TRUE);
+		gv_stashpvn(pname, 9, TRUE);
 		av_push(av, newSVpv(pname = "DB_File",0));
-		gv_stashpv(pname, TRUE);
+		gv_stashpvn(pname, 7, TRUE);
 		av_push(av, newSVpv(pname = "GDBM_File",0));
-		gv_stashpv(pname, TRUE);
+		gv_stashpvn(pname, 9, TRUE);
 		av_push(av, newSVpv(pname = "SDBM_File",0));
-		gv_stashpv(pname, TRUE);
+		gv_stashpvn(pname, 9, TRUE);
 		av_push(av, newSVpv(pname = "ODBM_File",0));
-		gv_stashpv(pname, TRUE);
+		gv_stashpvn(pname, 9, TRUE);
 	    }
 	}
 	break;
@@ -533,7 +631,7 @@ I32 sv_type;
     case 'O':
         if (strEQ(name, "OVERLOAD")) {
             HV* hv = GvHVn(gv);
-            SvMULTI_on(gv);
+            GvMULTI_on(gv);
             sv_magic((SV*)hv, (SV*)gv, 'A', 0, 0);
         }
         break;
@@ -541,11 +639,19 @@ I32 sv_type;
     case 'S':
 	if (strEQ(name, "SIG")) {
 	    HV *hv;
+	    I32 i;
 	    siggv = gv;
-	    SvMULTI_on(siggv);
+	    GvMULTI_on(siggv);
 	    hv = GvHVn(siggv);
 	    hv_magic(hv, siggv, 'S');
-
+	    for(i=1;sig_name[i];i++) {
+	    	SV ** init;
+	    	init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
+	    	if(init)
+	    		sv_setsv(*init,&sv_undef);
+	    	psig_ptr[i] = 0;
+	    	psig_name[i] = 0;
+	    }
 	    /* initialize signal stack */
 	    signalstack = newAV();
 	    AvREAL_off(signalstack);
@@ -581,6 +687,14 @@ 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 '#':
     case '*':
 	if (dowarn && len == 1 && sv_type == SVt_PV)
@@ -588,7 +702,6 @@ I32 sv_type;
 	/* FALL THROUGH */
     case '[':
     case '!':
-    case '?':
     case '^':
     case '~':
     case '=':
@@ -605,8 +718,10 @@ I32 sv_type;
     case '|':
     case '\001':
     case '\004':
+    case '\005':
     case '\006':
     case '\010':
+    case '\017':
     case '\t':
     case '\020':
     case '\024':
@@ -644,10 +759,11 @@ I32 sv_type;
 	break;
     case ']':
 	if (len == 1) {
-	    SV *sv;
-	    sv = GvSV(gv);
+	    SV *sv = GvSV(gv);
 	    sv_upgrade(sv, SVt_PVNV);
 	    sv_setpv(sv, patchlevel);
+	    (void)sv_2nv(sv);
+	    SvREADONLY_on(sv);
 	}
 	break;
     }
@@ -655,38 +771,50 @@ I32 sv_type;
 }
 
 void
-gv_fullname(sv,gv)
+gv_fullname3(sv, gv, prefix)
 SV *sv;
 GV *gv;
+char *prefix;
 {
     HV *hv = GvSTASH(gv);
-
-    if (!hv)
+    if (!hv) {
+	SvOK_off(sv);
 	return;
-    sv_setpv(sv, sv == (SV*)gv ? "*" : "");
+    }
+    sv_setpv(sv, prefix ? prefix : "");
     sv_catpv(sv,HvNAME(hv));
     sv_catpvn(sv,"::", 2);
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
 }
 
 void
-gv_efullname(sv,gv)
+gv_efullname3(sv, gv, prefix)
 SV *sv;
 GV *gv;
+char *prefix;
 {
-    GV* egv = GvEGV(gv);
-    HV *hv;
-    
+    GV *egv = GvEGV(gv);
     if (!egv)
 	egv = gv;
-    hv = GvSTASH(egv);
-    if (!hv)
-	return;
+    gv_fullname3(sv, egv, prefix);
+}
 
-    sv_setpv(sv, sv == (SV*)gv ? "*" : "");
-    sv_catpv(sv,HvNAME(hv));
-    sv_catpvn(sv,"::", 2);
-    sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_fullname(sv,gv)
+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_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
 }
 
 IO *
@@ -699,7 +827,9 @@ newIO()
     sv_upgrade((SV *)io,SVt_PVIO);
     SvREFCNT(io) = 1;
     SvOBJECT_on(io);
-    iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVIO);
+    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;
 }
@@ -717,23 +847,23 @@ HV* stash;
     if (!HvARRAY(stash))
 	return;
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
-	for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
-	    if (entry->hent_key[entry->hent_klen-1] == ':' &&
-		(gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
+	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+	    if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
+		(gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
 	    {
 		if (hv != defstash)
 		     gv_check(hv);              /* nested package */
 	    }
-	    else if (isALPHA(*entry->hent_key)) {
-		gv = (GV*)entry->hent_val;
-		if (SvMULTI(gv))
+	    else if (isALPHA(*HeKEY(entry))) {
+		gv = (GV*)HeVAL(entry);
+		if (GvMULTI(gv))
 		    continue;
 		curcop->cop_line = GvLINE(gv);
 		filegv = GvFILEGV(gv);
 		curcop->cop_filegv = filegv;
-		if (filegv && SvMULTI(filegv))	/* Filename began with slash */
+		if (filegv && GvMULTI(filegv))	/* Filename began with slash */
 		    continue;
-		warn("Identifier \"%s::%s\" used only once: possible typo",
+		warn("Name \"%s::%s\" used only once: possible typo",
 			HvNAME(stash), GvNAME(gv));
 	    }
 	}
@@ -744,8 +874,8 @@ GV *
 newGVgen(pack)
 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 */
@@ -755,17 +885,27 @@ gp_ref(gp)
 GP* gp;
 {
     gp->gp_refcnt++;
+    if (gp->gp_cv) {
+	if (gp->gp_cvgen) {
+	    /* multi-named GPs cannot be used for method cache */
+	    SvREFCNT_dec(gp->gp_cv);
+	    gp->gp_cv = Nullcv;
+	    gp->gp_cvgen = 0;
+	}
+	else {
+	    /* Adding a new name to a subroutine invalidates method cache */
+	    sub_generation++;
+	}
+    }
     return gp;
-
 }
 
 void
 gp_free(gv)
 GV* gv;
 {
-    IO *io;
-    CV *cv;
     GP* gp;
+    CV* cv;
 
     if (!gv || !(gp = GvGP(gv)))
 	return;
@@ -773,6 +913,10 @@ GV* gv;
         warn("Attempt to free unreferenced glob pointers");
         return;
     }
+    if (gp->gp_cv) {
+	/* Deleting the name of a subroutine invalidates method cache */
+	sub_generation++;
+    }
     if (--gp->gp_refcnt > 0) {
 	if (gp->gp_egv == gv)
 	    gp->gp_egv = 0;
@@ -782,12 +926,8 @@ GV* gv;
     SvREFCNT_dec(gp->gp_sv);
     SvREFCNT_dec(gp->gp_av);
     SvREFCNT_dec(gp->gp_hv);
-    if ((io = gp->gp_io) && SvTYPE(io) != SVTYPEMASK) {
-	do_close(gv,FALSE);
-	SvREFCNT_dec(io);
-    }
-    if ((cv = gp->gp_cv) && !GvCVGEN(gv))
-	SvREFCNT_dec(cv);
+    SvREFCNT_dec(gp->gp_io);
+    SvREFCNT_dec(gp->gp_cv);
     SvREFCNT_dec(gp->gp_form);
 
     Safefree(gp);
@@ -831,14 +971,14 @@ HV* stash;
   CV* cv;
   MAGIC* mg=mg_find((SV*)stash,'c');
   AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+  AMT amt;
 
-  if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
-             amtp->was_ok_sub == sub_generation)
-      return HV_AMAGIC(stash)? TRUE: FALSE;
-  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
-  if (amtp && amtp->table) {
+  if (mg && amtp->was_ok_am == amagic_generation
+      && amtp->was_ok_sub == sub_generation)
+      return AMT_AMAGIC(amtp);
+  if (amtp && AMT_AMAGIC(amtp)) {	/* Have table. */
     int i;
-    for (i=1;i<NofAMmeth*2;i++) {
+    for (i=1; i<NofAMmeth; i++) {
       if (amtp->table[i]) {
 	SvREFCNT_dec(amtp->table[i]);
       }
@@ -848,38 +988,33 @@ HV* stash;
 
   DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
 
+  amt.was_ok_am = amagic_generation;
+  amt.was_ok_sub = sub_generation;
+  amt.fallback = AMGfallNO;
+  amt.flags = 0;
+
+#ifdef OVERLOAD_VIA_HASH
+  gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);	/* A shortcut */
   if (gvp && ((gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv)))) {
     int filled=0;
     int i;
     char *cp;
-    AMT amt;
     SV* sv;
     SV** svp;
 
-/*  if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
-      DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
-);
-      return HV_AMAGIC(stash)? TRUE: FALSE;
-    }*/
-
-    amt.was_ok_am=amagic_generation;
-    amt.was_ok_sub=sub_generation;
-    amt.fallback=AMGfallNO;
-
     /* Work with "fallback" key, which we assume to be first in AMG_names */
 
-    if ((cp=((char**)(*AMG_names))[0]) &&
-	(svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
+    if (( cp = (char *)AMG_names[0] ) &&
+	(svp = (SV**)hv_fetch(hv,cp,strlen(cp),FALSE)) && (sv = *svp)) {
       if (SvTRUE(sv)) amt.fallback=AMGfallYES;
       else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
     }
-
-    for (i=1;i<NofAMmeth*2;i++) {
-      cv=0;
-
-      if ( (cp=((char**)(*AMG_names))[i]) ) {
-        svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
-        if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
+    for (i = 1; i < NofAMmeth; i++) {
+      cv = 0;
+      cp = (char *)AMG_names[i];
+      
+        svp = (SV**)hv_fetch(hv, cp, strlen(cp), FALSE);
+        if (svp && ((sv = *svp) != &sv_undef)) {
           switch (SvTYPE(sv)) {
             default:
               if (!SvROK(sv)) {
@@ -894,35 +1029,92 @@ HV* stash;
                 /* FALL THROUGH */
             case SVt_PVHV:
             case SVt_PVAV:
-	      die("Not a subroutine reference in %%OVERLOAD");
+	      croak("Not a subroutine reference in overload table");
 	      return FALSE;
             case SVt_PVCV:
-                cv = (CV*)sv;
-                break;
+              cv = (CV*)sv;
+              break;
             case SVt_PVGV:
-                if (!(cv = GvCV((GV*)sv)))
-                    cv = sv_2cv(sv, &stash, &gv, TRUE);
-                break;
+              if (!(cv = GvCVu((GV*)sv)))
+                cv = sv_2cv(sv, &stash, &gv, TRUE);
+              break;
           }
           if (cv) filled=1;
 	  else {
-	    die("Method for operation %s not found in package %.256s during blessing\n",
+	    croak("Method for operation %s not found in package %.256s during blessing\n",
 		cp,HvNAME(stash));
 	    return FALSE;
 	  }
         }
-      }
-      amt.table[i]=(CV*)SvREFCNT_inc(cv);
+#else
+  {
+    int filled = 0;
+    int i;
+    const char *cp;
+    SV* sv = NULL;
+    SV** svp;
+
+    /* Work with "fallback" key, which we assume to be first in AMG_names */
+
+    if ( cp = AMG_names[0] ) {
+	/* Try to find via inheritance. */
+	gv = gv_fetchmeth(stash, "()", 2, -1); /* A cookie: "()". */
+	if (gv) sv = GvSV(gv);
+
+	if (!gv) goto no_table;
+	else if (SvTRUE(sv)) amt.fallback=AMGfallYES;
+	else if (SvOK(sv)) amt.fallback=AMGfallNEVER;
+    }
+
+    for (i = 1; i < NofAMmeth; i++) {
+	SV *cookie = sv_2mortal(newSVpvf("(%s", cp = AMG_names[i]));
+	DEBUG_o( deb("Checking overloading of `%s' in package `%.256s'\n",
+		     cp, HvNAME(stash)) );
+	/* don't fill the cache while looking up! */
+	gv = gv_fetchmeth(stash, SvPVX(cookie), SvCUR(cookie), -1);
+        cv = 0;
+        if(gv && (cv = GvCV(gv))) {
+	    if (GvNAMELEN(CvGV(cv)) == 3 && strEQ(GvNAME(CvGV(cv)), "nil")
+		&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "overload")) {
+		/* GvSV contains the name of the method. */
+		GV *ngv;
+		
+		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_autoload(stash, SvPVX(GvSV(gv)),
+						       FALSE)))
+		{
+		    /* Can be an import stub (created by `can'). */
+		    if (GvCVGEN(gv)) {
+			croak("Stub found while resolving method `%.256s' overloading `%s' in package `%.256s'", 
+			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
+			      cp, HvNAME(stash));
+		    } else
+			croak("Cannot resolve method `%.256s' overloading `%s' in package `%.256s'", 
+			      (SvPOK(GvSV(gv)) ?  SvPVX(GvSV(gv)) : "???" ),
+			      cp, HvNAME(stash));
+		}
+		cv = GvCV(gv = ngv);
+	    }
+	    DEBUG_o( deb("Overloading `%s' in package `%.256s' via `%.256s::%.256s' \n",
+			 cp, HvNAME(stash), HvNAME(GvSTASH(CvGV(cv))),
+			 GvNAME(CvGV(cv))) );
+	    filled = 1;
+	}
+#endif 
+	amt.table[i]=(CV*)SvREFCNT_inc(cv);
     }
-    sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
     if (filled) {
-/*    HV_badAMAGIC_off(stash);*/
-      HV_AMAGIC_on(stash);
+      AMT_AMAGIC_on(&amt);
+      sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
       return TRUE;
     }
   }
-/*HV_badAMAGIC_off(stash);*/
-  HV_AMAGIC_off(stash);
+  /* Here we have no table: */
+ no_table:
+  AMT_AMAGIC_off(&amt);
+  sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
   return FALSE;
 }
 
@@ -945,7 +1137,9 @@ int flags;
   HV* stash;
   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
-      && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
+      && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
+			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+			: NULL))
       && ((cv = cvp[off=method+assignshift]) 
 	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
 						          * usual method */
@@ -978,16 +1172,20 @@ 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 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));
@@ -1032,7 +1230,9 @@ int flags;
 	 if (!cv) goto not_found;
     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
 	       && (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
-	       && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
+	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr) 
+			  ? (amtp = (AMT*)mg->mg_ptr)->table
+			  : NULL))
 	       && (cv = cvp[off=method])) { /* Method for right
 					     * argument found */
       lr=1;
@@ -1042,7 +1242,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 */
@@ -1069,15 +1269,18 @@ int flags;
 	goto not_found;
       }
     } else {
-    not_found:			/* No method found, either report or die */
+    not_found:			/* No method found, either report or croak */
       if (ocvp && (cv=ocvp[nomethod_amg])) { /* Call report method */
 	notfound = 1; lr = -1;
       } else if (cvp && (cv=cvp[nomethod_amg])) {
 	notfound = 1; lr = 1;
       } else {
-        if (off==-1) off=method;
-	sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
-		      ((char**)AMG_names)[method + assignshift],
+	SV *msg;
+	if (off==-1) off=method;
+	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)? 
 		        "in overloaded package ":
 		        "has no overloaded magic",
@@ -1085,27 +1288,30 @@ int flags;
 		        HvNAME(SvSTASH(SvRV(left))):
 		        "",
 		      SvAMAGIC(right)? 
-		        "in overloaded package ":
-		        "has no overloaded magic",
+		        ",\n\tright argument in overloaded package ":
+		        (flags & AMGf_unary 
+			 ? ""
+			 : ",\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 {
-	  die(buf);
+	  croak("%_", msg);
 	}
 	return NULL;
       }
     }
   }
   if (!notfound) {
-    DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
-		 ((char**)AMG_names)[off],
+    DEBUG_o( deb(
+  "Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %s%s\n",
+		 AMG_names[off],
 		 method+assignshift==off? "" :
 		             " (initially `",
 		 method+assignshift==off? "" :
-		             ((char**)AMG_names)[method+assignshift],
+		             AMG_names[method+assignshift],
 		 method+assignshift==off? "" : "')",
 		 flags & AMGf_unary? "" :
 		   lr==1 ? " for right argument": " for left argument",
@@ -1124,40 +1330,40 @@ 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;
 
     ENTER;
     SAVESPTR(op);
     op = (OP *) &myop;
+    if (PERLDB_SUB && curstash != debstash)
+	op->op_private |= OPpENTERSUB_DB;
     PUTBACK;
     pp_pushmark();
 
     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_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
     }
     PUSHs((SV*)cv);
     PUTBACK;
 
     if (op = pp_entersub())
-      run();
+      runops();
     LEAVE;
     SPAGAIN;
 
     res=POPs;
     PUTBACK;
-
-    if (notfound) {
-      /* sv_2mortal(res); */
-      return NULL;
-    }
+    CATCH_SET(oldcatch);
 
     if (postpr) {
       int ans;
@@ -1182,12 +1388,14 @@ int flags;
 	ans=SvIV(res)!=0; break;
       case inc_amg:
       case dec_amg:
-	SvSetSV(left,res); return res; break;
+	SvSetSV(left,res); return left;
+      case not_amg:
+	ans=!SvOK(res); break;
       }
-      return ans? &sv_yes: &sv_no;
+      return boolSV(ans);
     } else if (method==copy_amg) {
       if (!SvROK(res)) {
-	die("Copy method did not return a reference");
+	croak("Copy method did not return a reference");
       }
       return SvREFCNT_inc(SvRV(res));
     } else {