X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=gv.c;h=eb7b3ba2708af33fee4891991b73e1ad0e409f93;hb=52a55424e4624fc79eb8894fb91c5e2f4a9018ab;hp=3ac53064a051dc73a9914049af8a23747e29a766;hpb=9ed1afdbc1bed7621d245b873ba48f50bcb0f262;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/gv.c b/gv.c
index 3ac5306..eb7b3ba 100644
--- a/gv.c
+++ b/gv.c
@@ -46,9 +46,9 @@ Perl_gv_IOadd(pTHX_ register GV *gv)
     if (!gv || SvTYPE((SV*)gv) != SVt_PVGV)
 	Perl_croak(aTHX_ "Bad symbol for filehandle");
     if (!GvIOp(gv)) {
-#ifdef GV_SHARED_CHECK
-        if (GvSHARED(gv)) {
-            Perl_croak(aTHX_ "Bad symbol for filehandle (GV is shared)");
+#ifdef GV_UNIQUE_CHECK
+        if (GvUNIQUE(gv)) {
+            Perl_croak(aTHX_ "Bad symbol for filehandle (GV is unique)");
         }
 #endif
 	GvIOp(gv) = newIO();
@@ -72,6 +72,7 @@ Perl_gv_fetchfile(pTHX_ const char *name)
 	tmpbuf = smallbuf;
     else
 	New(603, tmpbuf, tmplen + 1, char);
+    /* This is where the debugger's %{"::_<$filename"} hash is created */
     tmpbuf[0] = '_';
     tmpbuf[1] = '<';
     strcpy(tmpbuf + 2, name);
@@ -128,13 +129,13 @@ 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_THREADS
+#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_THREADS */
+#endif /* USE_5005THREADS */
 	if (proto) {
 	    sv_setpv((SV*)GvCV(gv), proto);
 	    Safefree(proto);
@@ -411,8 +412,8 @@ 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)
 {
-    static char autoload[] = "AUTOLOAD";
-    static STRLEN autolen = 8;
+    char autoload[] = "AUTOLOAD";
+    STRLEN autolen = sizeof(autoload)-1;
     GV* gv;
     CV* cv;
     HV* varstash;
@@ -439,7 +440,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 	  "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
 	     HvNAME(stash), (int)len, name);
 
-#ifndef USE_THREADS
+#ifndef USE_5005THREADS
     if (CvXSUB(cv)) {
         /* rather than lookup/init $AUTOLOAD here
          * only to have the XSUB do another lookup for $AUTOLOAD
@@ -463,14 +464,14 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
     vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
     ENTER;
 
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
     sv_lock((SV *)varstash);
 #endif
     if (!isGV(vargv))
 	gv_init(vargv, varstash, autoload, autolen, FALSE);
     LEAVE;
     varsv = GvSV(vargv);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
     sv_lock(varsv);
 #endif
     sv_setpv(varsv, HvNAME(stash));
@@ -488,7 +489,7 @@ S_require_errno(pTHX_ GV *gv)
 {
     HV* stash = gv_stashpvn("Errno",5,FALSE);
 
-    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) {
+    if (!stash || !(gv_fetchmethod(stash, "TIEHASH"))) { 
 	dSP;
 	PUTBACK;
 	ENTER;
@@ -656,7 +657,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 		  strEQ(name, "ARGVOUT")))
 		    global = TRUE;
 	    }
-	    else if (*name == '_' && !name[1])
+	    else if (*name == '_' && (!name[1] || strEQ(name,"__ANON__")))
 		global = TRUE;
 
 	    if (global)
@@ -740,7 +741,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     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) ;
 
@@ -814,20 +815,16 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	break;
 
     case '&':
-	if (len > 1)
-	    break;
-	PL_sawampersand = TRUE;
-	goto ro_magicalize;
-
     case '`':
-	if (len > 1)
-	    break;
-	PL_sawampersand = TRUE;
-	goto ro_magicalize;
-
     case '\'':
-	if (len > 1)
-	    break;
+       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;
 
@@ -891,13 +888,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     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 '\020':	/* $^P */
-    case '\024':	/* $^T */
 	if (len > 1)
 	    break;
 	goto magicalize;
@@ -906,6 +901,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	    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;
@@ -914,6 +914,13 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 	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"))
@@ -938,6 +945,17 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     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;
+	    }
+	}
+
       ro_magicalize:
 	SvREADONLY_on(GvSV(gv));
       magicalize:
@@ -1279,7 +1297,7 @@ Perl_Gv_AMupdate(pTHX_ HV *stash)
 	    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;
+		GV *ngv = Nullgv;
 		
 		DEBUG_o( Perl_deb(aTHX_ "Resolving method `%.256s' for overloaded `%s' in package `%.256s'\n",
 			     SvPV_nolen(GvSV(gv)), cp, HvNAME(stash)) );
@@ -1359,13 +1377,13 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
   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;
+#ifdef DEBUGGING
   int fl=0;
+#endif
   HV* stash=NULL;
   if (!(AMGf_noleft & flags) && SvAMAGIC(left)
-      && (mg = mg_find((SV*)(
-			     stash=
-			     SvSTASH(SvRV(left))),
-			PERL_MAGIC_overload_table))
+      && (stash = SvSTASH(SvRV(left)))
+      && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
 			? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
 			: (CV **) NULL))
@@ -1373,7 +1391,9 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
 						          * usual method */
 		  (
+#ifdef DEBUGGING
 		   fl = 1,
+#endif 
 		   cv = cvp[off=method])))) {
     lr = -1;			/* Call method for left argument */
   } else {
@@ -1480,10 +1500,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 	 }
 	 if (!cv) goto not_found;
     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
-	       && (mg = mg_find((SV*)(
-				      stash=
-				      SvSTASH(SvRV(right))),
-			PERL_MAGIC_overload_table))
+	       && (stash = SvSTASH(SvRV(right)))
+	       && (mg = mg_find((SV*)stash, PERL_MAGIC_overload_table))
 	       && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
 			  ? (amtp = (AMT*)mg->mg_ptr)->table
 			  : (CV **) NULL))
@@ -1582,7 +1600,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 		     flags & AMGf_unary? "" :
 		     lr==1 ? " for right argument": " for left argument",
 		     flags & AMGf_unary? " for argument" : "",
-		     HvNAME(stash),
+		     stash ? HvNAME(stash) : "null",
 		     fl? ",\n\tassignment variant used": "") );
   }
 #endif
@@ -1777,11 +1795,14 @@ Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
     case '\016':   /* $^N */
     case '\020':   /* $^P */
     case '\023':   /* $^S */
-    case '\024':   /* $^T */
     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':