Merge 8.7

3 files changed, 100 insertions, 32 deletions

diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 827dabf..d368594 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -431,6 +431,53 @@ Tcl_SetByteArrayObj(
 /*
  *----------------------------------------------------------------------
  *
+ * TclGetBytesFromObj --
+ *
+ *	Attempt to extract the value from objPtr in the representation
+ *	of a byte sequence. On success return the extracted byte sequence.
+ *	On failures, return NULL and record error message and code in
+ *	interp (if not NULL).
+ *
+ * Results:
+ *	Pointer to array of bytes, or NULL. representing the ByteArray object.
+ *	Writes number of bytes in array to *lengthPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+unsigned char *
+TclGetBytesFromObj(
+    Tcl_Interp *interp,		/* For error reporting */
+    Tcl_Obj *objPtr,		/* Value to extract from */
+    int *lengthPtr)		/* If non-NULL, filled with length of the
+				 * array of bytes in the ByteArray object. */
+{
+    ByteArray *baPtr;
+    const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+
+    if (irPtr == NULL) {
+	SetByteArrayFromAny(NULL, objPtr);
+	irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+	if (irPtr == NULL) {
+	    if (interp) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"expected bytes but got non-byte character"));
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
+	    }
+	    return NULL;
+	}
+    }
+    baPtr = GET_BYTEARRAY(irPtr);
+
+    if (lengthPtr != NULL) {
+	*lengthPtr = baPtr->used;
+    }
+    return baPtr->bytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_GetByteArrayFromObj --
  *
  *	Attempt to get the array of bytes from the Tcl object. If the object
@@ -453,18 +500,16 @@ Tcl_GetByteArrayFromObj(
 				 * array of bytes in the ByteArray object. */
 {
     ByteArray *baPtr;
-    const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
+    const Tcl_ObjIntRep *irPtr;
+    unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr);
 
-    if (irPtr == NULL) {
-	irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
-	if (irPtr == NULL) {
-	    SetByteArrayFromAny(NULL, objPtr);
-	    irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
-	    if (irPtr == NULL) {
-		irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
-	    }
-	}
+    if (result) {
+	return result;
     }
+
+    irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
+    assert(irPtr != NULL);
+
     baPtr = GET_BYTEARRAY(irPtr);
 
     if (lengthPtr != NULL) {
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index bbbf977..bc51e0d 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -34,6 +34,27 @@ static struct {
 #endif
 } env;
 
+#if defined(_WIN32)
+#  define tenviron _wenviron
+#  define tenviron2utfdstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+		(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+#  define utf2tenvirondstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
+		(const WCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
+#  define techar WCHAR
+#  ifdef USE_PUTENV
+#    define putenv(env) _wputenv((const wchar_t *)env)
+#  endif
+#else 
+#  define tenviron environ
+#  define tenviron2utfdstr(tenvstr, len, dstr) \
+		Tcl_ExternalToUtfDString(NULL, tenvstr, len, dstr)
+#  define utf2tenvirondstr(str, len, dstr) \
+		Tcl_UtfToExternalDString(NULL, str, len, dstr)
+#  define techar char
+#endif
+
+#define tNTL sizeof(techar)
+
 /*
  * Declarations for local functions defined in this file:
  */
@@ -113,16 +134,16 @@ TclSetupEnv(
      * will hold just the parts to remove.
      */
 
-    if (environ[0] != NULL) {
+    if (tenviron[0] != NULL) {
 	int i;
 
 	Tcl_MutexLock(&envMutex);
-	for (i = 0; environ[i] != NULL; i++) {
+	for (i = 0; tenviron[i] != NULL; i++) {
 	    Tcl_Obj *obj1, *obj2;
 	    const char *p1;
 	    char *p2;
 
-	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
+	    p1 = tenviron2utfdstr(tenviron[i], -1, &envString);
 	    p2 = (char *)strchr(p1, '=');
 	    if (p2 == NULL) {
 		/*
@@ -219,7 +240,7 @@ TclSetEnv(
     size_t nameLength, valueLength;
     size_t index, length;
     char *p, *oldValue;
-    const char *p2;
+    const techar *p2;
 
     /*
      * Figure out where the entry is going to go. If the name doesn't already
@@ -238,18 +259,18 @@ TclSetEnv(
 	 * environment is the one we allocated. [Bug 979640]
 	 */
 
-	if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
+	if ((env.ourEnviron != (char *)tenviron) || (length+2 > env.ourEnvironSize)) {
 	    char **newEnviron = (char **)Tcl_Alloc((length + 5) * sizeof(char *));
 
-	    memcpy(newEnviron, environ, length * sizeof(char *));
+	    memcpy(newEnviron, tenviron, length * sizeof(char *));
 	    if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
 		Tcl_Free(env.ourEnviron);
 	    }
-	    environ = env.ourEnviron = newEnviron;
+	    tenviron = (techar **)(env.ourEnviron = newEnviron);
 	    env.ourEnvironSize = length + 5;
 	}
 	index = length;
-	environ[index + 1] = NULL;
+	tenviron[index + 1] = NULL;
 #endif /* USE_PUTENV */
 	oldValue = NULL;
 	nameLength = strlen(name);
@@ -264,7 +285,7 @@ TclSetEnv(
 	 * interpreters.
 	 */
 
-	oldEnv = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
+	oldEnv = tenviron2utfdstr(tenviron[index], -1, &envString);
 	if (strcmp(value, oldEnv + (length + 1)) == 0) {
 	    Tcl_DStringFree(&envString);
 	    Tcl_MutexUnlock(&envMutex);
@@ -272,7 +293,7 @@ TclSetEnv(
 	}
 	Tcl_DStringFree(&envString);
 
-	oldValue = environ[index];
+	oldValue = (char *)tenviron[index];
 	nameLength = length;
     }
 
@@ -287,14 +308,14 @@ TclSetEnv(
     memcpy(p, name, nameLength);
     p[nameLength] = '=';
     memcpy(p+nameLength+1, value, valueLength+1);
-    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
+    p2 = utf2tenvirondstr(p, -1, &envString);
 
     /*
      * Copy the native string to heap memory.
      */
 
-    p = (char *)Tcl_Realloc(p, Tcl_DStringLength(&envString) + 1);
-    memcpy(p, p2, Tcl_DStringLength(&envString) + 1);
+    p = (char *)Tcl_Realloc(p, Tcl_DStringLength(&envString) + tNTL);
+    memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL);
     Tcl_DStringFree(&envString);
 
 #ifdef USE_PUTENV
@@ -305,7 +326,7 @@ TclSetEnv(
     putenv(p);
     index = TclpFindVariable(name, &length);
 #else
-    environ[index] = p;
+    tenviron[index] = (techar *)p;
 #endif /* USE_PUTENV */
 
     /*
@@ -314,7 +335,7 @@ TclSetEnv(
      * string in the cache.
      */
 
-    if ((index != TCL_INDEX_NONE) && (environ[index] == p)) {
+    if ((index != TCL_INDEX_NONE) && (tenviron[index] == (techar *)p)) {
 	ReplaceString(oldValue, p);
 #ifdef HAVE_PUTENV_THAT_COPIES
     } else {
@@ -439,7 +460,7 @@ TclUnsetEnv(
      * Remember the old value so we can free it if Tcl created the string.
      */
 
-    oldValue = environ[index];
+    oldValue = (char *)tenviron[index];
 
     /*
      * Update the system environment. This must be done before we update the
@@ -463,10 +484,10 @@ TclUnsetEnv(
     string[length] = '\0';
 #endif /* _WIN32 */
 
-    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
-    string = (char *)Tcl_Realloc(string, Tcl_DStringLength(&envString) + 1);
+    utf2tenvirondstr(string, -1, &envString);
+    string = (char *)Tcl_Realloc(string, Tcl_DStringLength(&envString) + tNTL);
     memcpy(string, Tcl_DStringValue(&envString),
-	    Tcl_DStringLength(&envString)+1);
+	    Tcl_DStringLength(&envString) + tNTL);
     Tcl_DStringFree(&envString);
 
     putenv(string);
@@ -477,7 +498,7 @@ TclUnsetEnv(
      * string in the cache.
      */
 
-    if (environ[index] == string) {
+    if (tenviron[index] == (techar *)string) {
 	ReplaceString(oldValue, string);
 #ifdef HAVE_PUTENV_THAT_COPIES
     } else {
@@ -489,7 +510,7 @@ TclUnsetEnv(
 #endif /* HAVE_PUTENV_THAT_COPIES */
     }
 #else /* !USE_PUTENV_FOR_UNSET */
-    for (envPtr = environ+index+1; ; envPtr++) {
+    for (envPtr = (char **)(tenviron+index+1); ; envPtr++) {
 	envPtr[-1] = *envPtr;
 	if (*envPtr == NULL) {
 	    break;
@@ -538,7 +559,7 @@ TclGetEnv(
     if (index != TCL_AUTO_LENGTH) {
 	Tcl_DString envStr;
 
-	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
+	result = tenviron2utfdstr(tenviron[index], -1, &envStr);
 	result += length;
 	if (*result == '=') {
 	    result++;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 452d915..1f9bd11 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2957,6 +2957,8 @@ MODULE_SCOPE int	TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr,
 MODULE_SCOPE void	TclFSUnloadTempFile(Tcl_LoadHandle loadHandle);
 MODULE_SCOPE int *	TclGetAsyncReadyPtr(void);
 MODULE_SCOPE Tcl_Obj *	TclGetBgErrorHandler(Tcl_Interp *interp);
+MODULE_SCOPE unsigned char *	TclGetBytesFromObj(Tcl_Interp *interp,
+				    Tcl_Obj *objPtr, int *lengthPtr);
 MODULE_SCOPE int	TclGetChannelFromObj(Tcl_Interp *interp,
 			    Tcl_Obj *objPtr, Tcl_Channel *chanPtr,
 			    int *modePtr, int flags);