Merge core-8-5-branch.

If the string representation is invalidated, the Unicode intRep must be invalidated too.

6 files changed, 97 insertions, 61 deletions

diff --git a/ChangeLog b/ChangeLog
index fac0bd3..747e1e8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2013-02-05  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclLoadNone.c (TclpLoadMemory): [Bug 3433012]: Added dummy
+	version of this function to use in the event that a platform thinks it
+	can load from memory but cannot actually do so due to it being
+	disabled at configuration time.
+
 2013-01-30  Andreas Kupries  <andreask@activestate.com>
 
 	* library/platform/platform.tcl (::platform::LibcVersion): See
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index ccdab6e..3ee6ea7 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -268,17 +268,11 @@ Tcl_SetByteArrayObj(
 				 * >= 0. */
 {
     ByteArray *byteArrayPtr;
-    void *stringIntRep = NULL;
 
     if (Tcl_IsShared(objPtr)) {
 	Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
     }
-    /* If previous objType was string, keep the internal representation */
-    if (objPtr->typePtr == &tclStringType) {
-	stringIntRep = objPtr->internalRep.twoPtrValue.ptr1;
-    } else {
-	TclFreeIntRep(objPtr);
-    }
+    TclFreeIntRep(objPtr);
     Tcl_InvalidateStringRep(objPtr);
 
     if (length < 0) {
@@ -293,7 +287,6 @@ Tcl_SetByteArrayObj(
     }
     objPtr->typePtr = &tclByteArrayType;
     SET_BYTEARRAY(objPtr, byteArrayPtr);
-    objPtr->internalRep.twoPtrValue.ptr2 = stringIntRep;
 }
 
 /*
@@ -376,6 +369,10 @@ Tcl_SetByteArrayLength(
 	byteArrayPtr->allocated = length;
 	SET_BYTEARRAY(objPtr, byteArrayPtr);
     }
+    if ((objPtr)->internalRep.twoPtrValue.ptr2) {
+	ckfree((objPtr)->internalRep.twoPtrValue.ptr2);
+	(objPtr)->internalRep.twoPtrValue.ptr2 = NULL;
+    }
     Tcl_InvalidateStringRep(objPtr);
     byteArrayPtr->used = length;
     return byteArrayPtr->bytes;
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 6e7488c..d14e635 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -842,6 +842,10 @@ InvalidateDictChain(
     Dict *dict = dictObj->internalRep.twoPtrValue.ptr1;
 
     do {
+	if ((dictObj)->internalRep.twoPtrValue.ptr2) {
+	    ckfree((dictObj)->internalRep.twoPtrValue.ptr2);
+	    (dictObj)->internalRep.twoPtrValue.ptr2 = NULL;
+	}
 	Tcl_InvalidateStringRep(dictObj);
 	dict->epoch++;
 	dictObj = dict->chain;
@@ -896,6 +900,10 @@ Tcl_DictObjPut(
     }
 
     if (dictPtr->bytes != NULL) {
+	if ((dictPtr)->internalRep.twoPtrValue.ptr2) {
+	    ckfree((dictPtr)->internalRep.twoPtrValue.ptr2);
+	    (dictPtr)->internalRep.twoPtrValue.ptr2 = NULL;
+	}
 	Tcl_InvalidateStringRep(dictPtr);
     }
     dict = dictPtr->internalRep.twoPtrValue.ptr1;
@@ -998,6 +1006,10 @@ Tcl_DictObjRemove(
     }
 
     if (dictPtr->bytes != NULL) {
+	if ((dictPtr)->internalRep.twoPtrValue.ptr2) {
+	    ckfree((dictPtr)->internalRep.twoPtrValue.ptr2);
+	    (dictPtr)->internalRep.twoPtrValue.ptr2 = NULL;
+	}
 	Tcl_InvalidateStringRep(dictPtr);
     }
     dict = dictPtr->internalRep.twoPtrValue.ptr1;
@@ -2150,6 +2162,10 @@ DictIncrCmd(
 	}
     }
     if (code == TCL_OK) {
+	if ((dictPtr)->internalRep.twoPtrValue.ptr2) {
+	    ckfree((dictPtr)->internalRep.twoPtrValue.ptr2);
+	    (dictPtr)->internalRep.twoPtrValue.ptr2 = NULL;
+	}
 	Tcl_InvalidateStringRep(dictPtr);
 	valuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
 		dictPtr, TCL_LEAVE_ERR_MSG);
@@ -2239,6 +2255,10 @@ DictLappendCmd(
     if (allocatedValue) {
 	Tcl_DictObjPut(interp, dictPtr, objv[2], valuePtr);
     } else if (dictPtr->bytes != NULL) {
+	if ((dictPtr)->internalRep.twoPtrValue.ptr2) {
+	    ckfree((dictPtr)->internalRep.twoPtrValue.ptr2);
+	    (dictPtr)->internalRep.twoPtrValue.ptr2 = NULL;
+	}
 	Tcl_InvalidateStringRep(dictPtr);
     }
 
diff --git a/generic/tclLoadNone.c b/generic/tclLoadNone.c
index d328a41..af4ca81 100644
--- a/generic/tclLoadNone.c
+++ b/generic/tclLoadNone.c
@@ -134,6 +134,39 @@ TclpUnloadFile(
 }
 
 /*
+ * These functions are fallbacks if we somehow determine that the platform can
+ * do loading from memory but the user wishes to disable it. They just report
+ * (gracefully) that they fail.
+ */
+
+#ifdef TCL_LOAD_FROM_MEMORY
+
+MODULE_SCOPE void *
+TclpLoadMemoryGetBuffer(
+    Tcl_Interp *interp,		/* Dummy: unused by this implementation */
+    int size)			/* Dummy: unused by this implementation */
+{
+    return NULL;
+}
+
+MODULE_SCOPE int
+TclpLoadMemory(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    void *buffer,		/* Dummy: unused by this implementation */
+    int size,			/* Dummy: unused by this implementation */
+    int codeSize,		/* Dummy: unused by this implementation */
+    Tcl_LoadHandle *loadHandle,	/* Dummy: unused by this implementation */
+    Tcl_FSUnloadFileProc **unloadProcPtr)
+				/* Dummy: unused by this implementation */
+{
+    Tcl_SetResult(interp, "dynamic loading from memory is not available "
+	    "on this system", TCL_STATIC);
+    return TCL_ERROR;
+}
+
+#endif /* TCL_LOAD_FROM_MEMORY */
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclVar.c b/generic/tclVar.c
index c571f2f..d000296 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -473,7 +473,9 @@ TclObjLookupVar(
 
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
-	Tcl_IncrRefCount(part2Ptr);
+	if (createPart2) {
+	    Tcl_IncrRefCount(part2Ptr);
+	}
     }
 
     resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -486,6 +488,12 @@ TclObjLookupVar(
     return resPtr;
 }
 
+/*
+ *	When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ *	plan to DecrRefCount it.
+ *	When createPart2 is 1, callers must IncrRefCount part2Ptr if they
+ *	plan to DecrRefCount it.
+ */
 Var *
 TclObjLookupVarEx(
     Tcl_Interp *interp,		/* Interpreter to use for lookup. */
@@ -626,7 +634,9 @@ TclObjLookupVarEx(
 	    part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
 	    if (newPart2) {
 		part2Ptr = Tcl_NewStringObj(newPart2, -1);
-		Tcl_IncrRefCount(part2Ptr);
+		if (createPart2) {
+		    Tcl_IncrRefCount(part2Ptr);
+		}
 	    }
 	    part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
 	    typePtr = part1Ptr->typePtr;
@@ -670,7 +680,9 @@ TclObjLookupVarEx(
 		*(newPart2+len2) = '\0';
 		part2 = newPart2;
 		part2Ptr = Tcl_NewStringObj(newPart2, -1);
-		Tcl_IncrRefCount(part2Ptr);
+		if (createPart2) {
+		    Tcl_IncrRefCount(part2Ptr);
+		}
 
 		/*
 		 * Free the internal rep of the original part1Ptr, now renamed
@@ -1077,6 +1089,8 @@ TclLookupSimpleVar(
  *	The variable at arrayPtr may be converted to be an array if
  *	createPart1 is 1. A new hashtable entry may be created if createPart2
  *	is 1.
+ *	When createElem is 1, callers must incr elNamePtr if they plan
+ *	to decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -1205,17 +1219,7 @@ Tcl_GetVar(
 				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
 				 * bits. */
 {
-    Tcl_Obj *varNamePtr, *resultPtr;
-
-    varNamePtr = Tcl_NewStringObj(varName, -1);
-    Tcl_IncrRefCount(varNamePtr);
-    resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
-    TclDecrRefCount(varNamePtr);
-
-    if (resultPtr == NULL) {
-	return NULL;
-    }
-    return TclGetString(resultPtr);
+    return Tcl_GetVar2(interp, varName, NULL, flags);
 }
 
 /*
@@ -1253,27 +1257,13 @@ Tcl_GetVar2(
 				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
 				 * bits. */
 {
-    Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
-
-    part1Ptr = Tcl_NewStringObj(part1, -1);
-    Tcl_IncrRefCount(part1Ptr);
-    if (part2) {
-	part2Ptr = Tcl_NewStringObj(part2, -1);
-	Tcl_IncrRefCount(part2Ptr);
-    } else {
-	part2Ptr = NULL;
-    }
-
-    resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
+    Tcl_Obj *objPtr;
 
-    Tcl_DecrRefCount(part1Ptr);
-    if (part2Ptr) {
-	Tcl_DecrRefCount(part2Ptr);
-    }
-    if (resultPtr == NULL) {
+    objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
+    if (objPtr == NULL) {
 	return NULL;
     }
-    return TclGetString(resultPtr);
+    return TclGetString(objPtr);
 }
 
 /*
@@ -1312,7 +1302,6 @@ Tcl_GetVar2Ex(
 {
     Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
 
-    Tcl_IncrRefCount(part1Ptr);
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
 	Tcl_IncrRefCount(part2Ptr);
@@ -1348,6 +1337,8 @@ Tcl_GetVar2Ex(
  *	the returned reference; if you want to keep a reference to the object
  *	you must increment its ref count yourself.
  *
+ *	Callers must incr part2Ptr if they plan to decr it.
+ *
  *----------------------------------------------------------------------
  */
 
@@ -1552,21 +1543,7 @@ Tcl_SetVar(
 				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
 				 * TCL_LEAVE_ERR_MSG. */
 {
-    Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
-
-    varNamePtr = Tcl_NewStringObj(varName, -1);
-    Tcl_IncrRefCount(varNamePtr);
-    valuePtr = Tcl_NewStringObj(newValue, -1);
-    Tcl_IncrRefCount(valuePtr);
-
-    varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
-
-    Tcl_DecrRefCount(varNamePtr);
-    Tcl_DecrRefCount(valuePtr);
-    if (varValuePtr == NULL) {
-	return NULL;
-    }
-    return TclGetString(varValuePtr);
+    return Tcl_SetVar2(interp, varName, NULL, newValue, flags);
 }
 
 /*
@@ -1710,6 +1687,7 @@ Tcl_SetVar2Ex(
  *	The value of the given variable is set. If either the array or the
  *	entry didn't exist then a new variable is created.
  *	Callers must Incr part1Ptr if they plan to Decr it.
+ *	Callers must Incr part2Ptr if they plan to Decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -1998,6 +1976,7 @@ TclPtrSetVar(
  *	incremented to reflect the returned reference; if you want to keep a
  *	reference to the object you must increment its ref count yourself.
  *	Callers must Incr part1Ptr if they plan to Decr it.
+ *	Callers must Incr part2Ptr if they plan to Decr it.
  *
  *----------------------------------------------------------------------
  */
@@ -2191,10 +2170,8 @@ Tcl_UnsetVar2(
     int result;
     Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
 
-    Tcl_IncrRefCount(part1Ptr);
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
-	Tcl_IncrRefCount(part2Ptr);
     }
 
     /*
@@ -4738,10 +4715,8 @@ TclVarErrMsg(
 {
     Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
 
-    Tcl_IncrRefCount(part1Ptr);
     if (part2) {
 	part2Ptr = Tcl_NewStringObj(part2, -1);
-	Tcl_IncrRefCount(part2Ptr);
     }
 
     TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
@@ -5009,7 +4984,6 @@ Tcl_FindNamespaceVar(
     Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
     Tcl_Var var;
 
-    Tcl_IncrRefCount(namePtr);
     var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
     Tcl_DecrRefCount(namePtr);
     return var;
diff --git a/tests/set.test b/tests/set.test
index 9e0ddc0..cad951b 100644
--- a/tests/set.test
+++ b/tests/set.test
@@ -521,6 +521,11 @@ test set-5.1 {error on malformed array name} testset2 {
     list $msg $msg1
 } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}}
 
+# In a mem-debug build, this test will crash unless Bug 3602706 is fixed.
+test set-5.2 {Bug 3602706} -body {
+    testset2 ::tcl_platform not-in-there
+} -returnCodes error -result * -match glob
+
 # cleanup
 catch {unset a}
 catch {unset b}