X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=2fe604b2c8175ec97f63b5bdd886ce45a80382d0;hb=d3c54a8ee31058f7959aacfbb3392e838bcff1b6;hp=8dfa932e42ea30693de17c5a8a1a62cf0a05d967;hpb=fde18df140d5f64815bdd632a127ecd5ce3d97fa;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 8dfa932..2fe604b 100644
--- a/gv.c
+++ b/gv.c
@@ -1,6 +1,7 @@
 /*    gv.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 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.
@@ -193,6 +194,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    return 0;
     }
 
+    if (!HvNAME(stash))
+      Perl_croak(aTHX_
+		 "Can't use anonymous symbol table for method lookup");
+
     if ((level > 100) || (level < -100))
 	Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 	      name, HvNAME(stash));
@@ -687,8 +692,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 */
 
@@ -758,14 +761,19 @@ 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));
+		  : ""), name);
+	    if (USE_UTF8_IN_NAMES)
+		SvUTF8_on(err);
+	    qerror(err);
+	    stash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
 	}
-	return Nullgv;
+	else
+	    return Nullgv;
     }
 
     if (!SvREFCNT(stash))	/* symbol table under destruction */
@@ -920,10 +928,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	    SvREADONLY_on(av);
         }
 	goto magicalize;
-    case '#':
     case '*':
-	if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && len == 1 && sv_type == SVt_PV)
-	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Use of $%s is deprecated", name);
+	if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+		    "$* is no longer supported");
+	break;
+    case '#':
+	if (len == 1 && sv_type == SVt_PV && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+	    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+		    "Use of $# is deprecated");
 	/* FALL THROUGH */
     case '[':
     case '^':
@@ -975,7 +988,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
         else
             break;
     case '\025':
-        if (len > 1 && strNE(name, "\025TF8_LOCALE")) 
+        if (len > 1 && strNE(name, "\025NICODE")) 
 	    break;
 	goto ro_magicalize;
 
@@ -1063,14 +1076,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 void
 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 {
+    char *name;
     HV *hv = GvSTASH(gv);
     if (!hv) {
 	(void)SvOK_off(sv);
 	return;
     }
     sv_setpv(sv, prefix ? prefix : "");
-    if (keepmain || strNE(HvNAME(hv), "main")) {
-	sv_catpv(sv,HvNAME(hv));
+    
+    if (!HvNAME(hv))
+	name = "__ANON__";
+    else 
+	name = HvNAME(hv);
+    if (keepmain || strNE(name, "main")) {
+	sv_catpv(sv,name);
 	sv_catpvn(sv,"::", 2);
     }
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
@@ -1121,6 +1140,9 @@ Perl_newIO(pTHX)
     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))))
@@ -1142,7 +1164,7 @@ Perl_gv_check(pTHX_ HV *stash)
     for (i = 0; i <= (I32) HvMAX(stash); i++) {
 	for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
 	    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 */
@@ -1233,12 +1255,18 @@ 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_sv) SvREFCNT_dec(gp->gp_av);
+    if (gp->gp_hv) {
+	 if (PL_stashcache && HvNAME(gp->gp_hv))
+	      hv_delete(PL_stashcache,
+			HvNAME(gp->gp_hv), strlen(HvNAME(gp->gp_hv)),
+			G_DISCARD);
+	 SvREFCNT_dec(gp->gp_hv);
+    }
+    if (gp->gp_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;
@@ -1334,7 +1362,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 		/* GvSV contains the name of the method. */
 		GV *ngv = Nullgv;
 		
-		DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256"SVf"' for overloaded `%s' in package `%.256s'\n",
+		DEBUG_o( Perl_deb(aTHX_ "Resolving method `%"SVf256\
+			"' for overloaded `%s' in package `%.256s'\n",
 			     GvSV(gv), cp, HvNAME(stash)) );
 		if (!SvPOK(GvSV(gv))
 		    || !(ngv = gv_fetchmethod_autoload(stash, SvPVX(GvSV(gv)),
@@ -1343,7 +1372,8 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 		    /* Can be an import stub (created by `can'). */
 		    SV *gvsv = GvSV(gv);
 		    const char *name = SvPOK(gvsv) ?  SvPVX(gvsv) : "???";
-		    Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' in package `%.256s'",
+		    Perl_croak(aTHX_ "%s method `%.256s' overloading `%s' "\
+				"in package `%.256s'",
 			       (GvCVGEN(gv) ? "Stub found while resolving"
 				: "Can't resolve"),
 			       name, cp, HvNAME(stash));
@@ -1387,7 +1417,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     AMT *amtp;
     CV *ret;
 
-    if (!stash)
+    if (!stash || !HvNAME(stash))
         return Nullcv;
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
@@ -1800,7 +1830,7 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
 	}
 	break;
     case '\025':
-        if (len > 1 && strEQ(name, "\025TF8_LOCALE"))
+        if (len > 1 && strEQ(name, "\025NICODE"))
 	    goto yes;
     case '\027':   /* $^W & $^WARNING_BITS */
 	if (len == 1
@@ -1819,7 +1849,6 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
     case '!':
     case '-':
     case '#':
-    case '*':
     case '[':
     case '^':
     case '~':