Store userEncoding in Thread Local Storage

No need to put it in change log, because regression was caused by [4128866276b86868]

.github/workflows/onefiledist.yml

@@ -153,6 +153,7 @@ jobs:
         run: |
           make binaries libraries
           echo "TCL_ZIP=`pwd`/`echo libtcl*.zip`" >> $GITHUB_ENV
+          rm tclsh*c*.exe
         working-directory: win
       - name: Get Exact Version
         run: |

changes.md

@@ -11,8 +11,8 @@ to the userbase.
 
 # Bug fixes
  - [Better error-message than "interpreter uses an incompatible stubs mechanism"](https://core.tcl-lang.org/tcl/tktview/fc3509)
- - [$interp eval $lambda] after [eval $lambda] or vice versa fails](https://core.tcl-lang.org/tcl/tktview/98006f)
- - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/67d5f7)
+ - [\[$interp eval $lambda\] after \[eval $lambda\] or vice versa fails](https://core.tcl-lang.org/tcl/tktview/67d5f7)
+ - [tcl::mathfunc::isunordered inconsistency with some integer values](https://core.tcl-lang.org/tcl/tktview/98006f)
  - [test lseq hangs with -Os](https://core.tcl-lang.org/tcl/tktview/d2a3c5)
  - [exec does not handle app execution aliases on Windows](https://core.tcl-lang.org/tcl/tktview/4f0b57)
  - [auto_execok does not find several built-in cmd commands](https://core.tcl-lang.org/tcl/tktview/4e2c8b)
@@ -23,6 +23,10 @@ to the userbase.
  - [tclEpollNotfy PlatformEventsControl panics if websocket disconnected](https://core.tcl-lang.org/tcl/tktview/010d8f)
  - [Tcl_InitStubs compatibility for 9.1](https://core.tcl-lang.org/tcl/tktview/fd8341)
  - [proc with more than 2**31 variables](https://core.tcl-lang.org/tcl/tktview/92aeb8)
+ - [scan "long mantissa" %g](https://core.tcl-lang.org/tcl/tktview/42d14c)
+ - ["encoding system": wrong result without manifest](https://core.tcl-lang.org/tcl/tktview/8ffd8c)
+ - [lseq crash on out-of-range index](https://core.tcl-lang.org/tcl/tktview/7d3101)
+ - [lseq crash on nested indices](https://core.tcl-lang.org/tcl/tktview/452b10)
 
 # Incompatibilities
  - No known incompatibilities with the Tcl 9.0.0 public interface.

doc/Object.3

@@ -28,7 +28,7 @@ Tcl_Obj *
 int
 \fBTcl_IsShared\fR(\fIobjPtr\fR)
 .sp
-\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)3
+\fBTcl_InvalidateStringRep\fR(\fIobjPtr\fR)
 .fi
 .SH ARGUMENTS
 .AS Tcl_Obj *objPtr

doc/ObjectType.3

@@ -128,6 +128,17 @@ When \fInumBytes\fR is greater than zero, and the returned pointer is
 representation.
 The caller may then choose whether to raise an error or panic.
 .PP
+\fBTcl_InitStringRep\fR performs the function of the existing internal macro
+\fBTclInitStringRep\fR, but is extended to return a pointer to the string rep,
+and to accept \fBNULL\fR as a value for bytes.
+When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has no string rep, an uninitialzed
+buffer of numBytes bytes is created for filling by the caller.
+When \fIbytes\fR is \fBNULL\fR and \fIobjPtr\fR has a string rep, the string
+rep will be truncated to a length of numBytes bytes.
+When numBytes is greater than zero, and the returned pointer is \fBNULL\fR, that
+indicates a failure to allocate memory for the string representation.
+The caller may then choose whether to raise an error or panic.
+.PP
 \fBTcl_HasStringRep\fR returns a boolean indicating whether or not a string
 rep is currently stored in \fIobjPtr\fR.
 This is used when the caller wants to act on \fIobjPtr\fR differently

generic/tclArithSeries.c

@@ -1150,11 +1150,11 @@ UpdateStringOfArithSeries(
 {
     ArithSeries *arithSeriesRepPtr = (ArithSeries *)
 	    arithSeriesObjPtr->internalRep.twoPtrValue.ptr1;
-    char *p;
+    char *p, *srep;
     Tcl_Size i, bytlen = 0;
 
-    if (!arithSeriesRepPtr->len) {
-	TclInitEmptyStringRep(arithSeriesObjPtr);
+    if (arithSeriesRepPtr->len == 0) {
+	(void)Tcl_InitStringRep(arithSeriesObjPtr, NULL, 0);
 	return;
     }
 
@@ -1172,15 +1172,17 @@ UpdateStringOfArithSeries(
 	char tmp[TCL_DOUBLE_SPACE + 2];
 	for (i = 0; i < arithSeriesRepPtr->len; i++) {
 	    double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i);
+	    Tcl_Size elen;
 
 	    tmp[0] = '\0';
 	    Tcl_PrintDouble(NULL,d,tmp);
-	    bytlen += strlen(tmp);
-	    if (bytlen > TCL_SIZE_MAX) {
+	    elen = strlen(tmp);
+	    if (bytlen > TCL_SIZE_MAX - elen) {
 		/* overflow, todo: check we could use some representation instead of the panic
 		 * to signal it is too large for string representation, because too heavy */
 		Tcl_Panic("UpdateStringOfArithSeries: too large to represent");
 	    }
+	    bytlen += elen;
 	}
     }
     bytlen += arithSeriesRepPtr->len; // Space for each separator
@@ -1189,7 +1191,9 @@ UpdateStringOfArithSeries(
      * Pass 2: generate the string repr.
      */
 
-    p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
+    p = srep = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen);
+    TclOOM(p, bytlen+1);
+
     if (!arithSeriesRepPtr->isDouble) {
 	for (i = 0; i < arithSeriesRepPtr->len; i++) {
 	    Tcl_WideInt d = ArithSeriesIndexInt(arithSeriesRepPtr, i);
@@ -1208,8 +1212,7 @@ UpdateStringOfArithSeries(
 	    *p++ = ' ';
 	}
     }
-    *(--p) = '\0';
-    arithSeriesObjPtr->length = p - arithSeriesObjPtr->bytes;
+    (void) Tcl_InitStringRep(arithSeriesObjPtr, NULL, (--p - srep));
 }
 
 /*

generic/tclClock.c

@@ -116,7 +116,7 @@ struct ClockCommand {
     const char *name;		/* The tail of the command name. The full name
 				 * is "::tcl::clock::<name>". When NULL marks
 				 * the end of the table. */
-    Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This
+    Tcl_ObjCmdProc *objCmdProc;	/* Function that implements the command. This
 				 * will always have the ClockClientData sent
 				 * to it, but may well ignore this data. */
     CompileProc *compileProc;	/* The compiler for the command. */
@@ -341,7 +341,7 @@ ClockConfigureClear(
  */
 static void
 ClockDeleteCmdProc(
-    void *clientData)	/* Opaque pointer to the client data */
+    void *clientData)		/* Opaque pointer to the client data */
 {
     ClockClientData *data = (ClockClientData *)clientData;
     int i;
@@ -3277,7 +3277,7 @@ ClockParseFmtScnArgs(
     ClockFmtScnCmdArgs *opts,	/* Result vector: format, locale, timezone... */
     TclDateFields *date,	/* Extracted date-time corresponding base
 				 * (by scan or add) resp. clockval (by format) */
-    Tcl_Size objc,			/* Parameter count */
+    Tcl_Size objc,		/* Parameter count */
     Tcl_Obj *const objv[],	/* Parameter vector */
     ClockOperation operation,	/* What operation are we doing: format, scan, add */
     const char *syntax)		/* Syntax of the current command */
@@ -4255,7 +4255,7 @@ ClockCalcRelTime(
 	 * and hereafter convert back to TZ, otherwise apply it direct here.
 	 */
 	if (opts->timezoneObj != opts->dataPtr->literals[LIT_GMT]) {
-	    /* 
+	    /*
 	     * Convert date info structure into UTC seconds and add relative
 	     * seconds (happens in commit).
 	     */
@@ -4277,7 +4277,7 @@ ClockCalcRelTime(
 	    /* restore scanned day of week */
 	    yyDayOfWeek = prevDayOfWeek;
 	} else {
-	    /* 
+	    /*
 	     * GMT/UTC zone, so no DST and no offsets - apply it here, so that
 	     * if time exceeds current date, do the day conversion and leave the
 	     * rest of increment in yyRelSeconds (add it later in UTC by commit)
@@ -4625,11 +4625,11 @@ ClockSafeCatchCmd(
     Tcl_Obj *const objv[])
 {
     typedef struct {
-	int status;			/* return code status */
-	int flags;			/* Each remaining field saves the */
-	int returnLevel;		/* corresponding field of the Interp */
-	int returnCode;			/* struct. These fields taken together are */
-	Tcl_Obj *errorInfo;		/* the "state" of the interp. */
+	int status;		/* return code status */
+	int flags;		/* Each remaining field saves the */
+	int returnLevel;	/* corresponding field of the Interp */
+	int returnCode;		/* struct. These fields taken together are */
+	Tcl_Obj *errorInfo;	/* the "state" of the interp. */
 	Tcl_Obj *errorCode;
 	Tcl_Obj *returnOpts;
 	Tcl_Obj *objResult;

generic/tclCmdAH.c

@@ -53,6 +53,7 @@ static Tcl_ObjCmdProc	EncodingDirsObjCmd;
 static Tcl_ObjCmdProc	EncodingNamesObjCmd;
 static Tcl_ObjCmdProc	EncodingProfilesObjCmd;
 static Tcl_ObjCmdProc	EncodingSystemObjCmd;
+static Tcl_ObjCmdProc	EncodingUserObjCmd;
 static inline int	ForeachAssignments(Tcl_Interp *interp,
 			    struct ForeachState *statePtr);
 static inline void	ForeachCleanup(Tcl_Interp *interp,
@@ -394,6 +395,7 @@ TclInitEncodingCmd(
 	{"names",       EncodingNamesObjCmd,       TclCompileBasic0ArgCmd,    NULL, NULL, 0},
 	{"profiles",    EncodingProfilesObjCmd,    TclCompileBasic0ArgCmd,    NULL, NULL, 0},
 	{"system",      EncodingSystemObjCmd,      TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+	{"user",        EncodingUserObjCmd,        TclCompileBasic0ArgCmd,    NULL, NULL, 1},
 	{NULL,          NULL,                      NULL,                      NULL, NULL, 0}
     };
 
@@ -828,6 +830,41 @@ EncodingSystemObjCmd(
     return TCL_OK;
 }
 
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * EncodingUserObjCmd --
+ *
+ *	This command retrieves the encoding as per the user settings.
+ *
+ * Results:
+ *	Returns a standard Tcl result
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+EncodingUserObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp* interp,     /* Tcl interpreter */
+    int objc,		    /* Number of command line args */
+    Tcl_Obj* const objv[])  /* Vector of command line args */
+{
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "");
+	return TCL_ERROR;
+    }
+#ifdef _WIN32
+    const char *encodingName = Tcl_GetEncodingName(TclWinGetUserEncoding(interp));
+    if (encodingName) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(encodingName, -1));
+    }
+    return TCL_OK;
+#else
+    return EncodingSystemObjCmd(NULL, interp, objc, objv);
+#endif
+}
+
 /*
  *----------------------------------------------------------------------
  *

generic/tclExecute.c

@@ -4715,30 +4715,26 @@ TEBCresume(
 	if (TclObjTypeHasProc(valuePtr, indexProc)) {
 	    DECACHE_STACK_INFO();
 	    length = TclObjTypeLength(valuePtr);
-	    if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+	    if (TclGetIntForIndexM(NULL, value2Ptr, length-1, &index)!=TCL_OK) {
 		CACHE_STACK_INFO();
-		TRACE_ERROR(interp);
-		goto gotError;
-	    }
-	    if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) {
+		/* Could be list of indices. Let TclLindexList handle it below */
+	    } else {
+		if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr) !=
+		    TCL_OK) {
+		    CACHE_STACK_INFO();
+		    TRACE_ERROR(interp);
+		    goto gotError;
+		}
 		CACHE_STACK_INFO();
-		TRACE_ERROR(interp);
-		goto gotError;
+		if (objResultPtr == NULL) {
+		    /* Index is out of range, return empty result. */
+		    TclNewObj(objResultPtr);
+		}
+		Tcl_IncrRefCount(objResultPtr); // reference held here
+		goto lindexDone;
 	    }
-	    CACHE_STACK_INFO();
-	    if (objResultPtr == NULL) {
-		/* Index is out of range, return empty result. */
-		TclNewObj(objResultPtr);
-	    }
-	    Tcl_IncrRefCount(objResultPtr); // reference held here
-	    goto lindexDone;
-	}
-
-	/*
-	 * Extract the desired list element.
-	 */
-
-	{
+	} else {
+	    /* Non-abstract list */
 	    Tcl_Size value2Length;
 	    Tcl_Obj *indexListPtr = value2Ptr;
 

generic/tclIO.c

@@ -69,7 +69,7 @@ typedef struct GetsState {
     char **dstPtr;		/* Pointer into objPtr's string rep where
 				 * next character should be stored. */
     Tcl_Encoding encoding;	/* The encoding to use to convert raw bytes
-				 * to UTF-8.  */
+				 * to UTF-8. */
     ChannelBuffer *bufPtr;	/* The current buffer of raw bytes being
 				 * emptied. */
     Tcl_EncodingState state;	/* The encoding state just before the last
@@ -336,27 +336,27 @@ static void		FreeChannelInternalRep(Tcl_Obj *objPtr);
 
 static const Tcl_ObjType chanObjType = {
     "channel",			/* name for this type */
-    FreeChannelInternalRep,		/* freeIntRepProc */
-    DupChannelInternalRep,		/* dupIntRepProc */
+    FreeChannelInternalRep,	/* freeIntRepProc */
+    DupChannelInternalRep,	/* dupIntRepProc */
     NULL,			/* updateStringProc */
     NULL,			/* setFromAnyProc */
     TCL_OBJTYPE_V0
 };
 
-#define ChanSetInternalRep(objPtr, resPtr)					\
+#define ChanSetInternalRep(objPtr, resPtr) \
     do {								\
 	Tcl_ObjInternalRep ir;						\
 	(resPtr)->refCount++;						\
 	ir.twoPtrValue.ptr1 = (resPtr);					\
 	ir.twoPtrValue.ptr2 = NULL;					\
-	Tcl_StoreInternalRep((objPtr), &chanObjType, &ir);			\
+	Tcl_StoreInternalRep((objPtr), &chanObjType, &ir);		\
     } while (0)
 
-#define ChanGetInternalRep(objPtr, resPtr)					\
+#define ChanGetInternalRep(objPtr, resPtr) \
     do {								\
-	const Tcl_ObjInternalRep *irPtr;					\
+	const Tcl_ObjInternalRep *irPtr;				\
 	irPtr = TclFetchInternalRep((objPtr), &chanObjType);		\
-	(resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL;		\
+	(resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
     } while (0)
 
 #define BUSY_STATE(st, fl) \
@@ -847,7 +847,7 @@ Tcl_CreateCloseHandler(
 				 * callback. */
     Tcl_CloseProc *proc,	/* The callback routine to call when the
 				 * channel will be closed. */
-    void *clientData)	/* Arbitrary data to pass to the close
+    void *clientData)		/* Arbitrary data to pass to the close
 				 * callback. */
 {
     ChannelState *statePtr = ((Channel *) chan)->state;
@@ -885,7 +885,7 @@ Tcl_DeleteCloseHandler(
 				 * callback. */
     Tcl_CloseProc *proc,	/* The procedure for the callback to
 				 * remove. */
-    void *clientData)	/* The callback data for the callback to
+    void *clientData)		/* The callback data for the callback to
 				 * remove. */
 {
     ChannelState *statePtr = ((Channel *) chan)->state;
@@ -984,7 +984,7 @@ GetChannelTable(
 
 static void
 DeleteChannelTable(
-    void *clientData,	/* The per-interpreter data structure. */
+    void *clientData,		/* The per-interpreter data structure. */
     Tcl_Interp *interp)		/* The interpreter being deleted. */
 {
     Tcl_HashTable *hTblPtr;	/* The hash table. */
@@ -2493,7 +2493,7 @@ Tcl_RemoveChannelMode(
 
 static ChannelBuffer *
 AllocChannelBuffer(
-    Tcl_Size length)			/* Desired length of channel buffer. */
+    Tcl_Size length)		/* Desired length of channel buffer. */
 {
     ChannelBuffer *bufPtr;
     Tcl_Size n;
@@ -4062,7 +4062,7 @@ Tcl_Size
 Tcl_Write(
     Tcl_Channel chan,		/* The channel to buffer output for. */
     const char *src,		/* Data to queue in output buffer. */
-    Tcl_Size srcLen)			/* Length of data in bytes, or TCL_INDEX_NONE for
+    Tcl_Size srcLen)		/* Length of data in bytes, or TCL_INDEX_NONE for
 				 * strlen(). */
 {
     /*
@@ -4174,7 +4174,7 @@ Tcl_WriteChars(
     Tcl_Channel chan,		/* The channel to buffer output for. */
     const char *src,		/* UTF-8 characters to queue in output
 				 * buffer. */
-    Tcl_Size len)			/* Length of string in bytes, or TCL_INDEX_NONE for
+    Tcl_Size len)		/* Length of string in bytes, or TCL_INDEX_NONE for
 				 * strlen(). */
 {
     Channel *chanPtr = (Channel *) chan;
@@ -4352,7 +4352,7 @@ static Tcl_Size
 Write(
     Channel *chanPtr,		/* The channel to buffer output for. */
     const char *src,		/* UTF-8 string to write. */
-    Tcl_Size srcLen,	    /* Length of UTF-8 string in bytes. */
+    Tcl_Size srcLen,		/* Length of UTF-8 string in bytes. */
     Tcl_Encoding encoding)
 {
     ChannelState *statePtr = chanPtr->state;
@@ -5715,7 +5715,7 @@ Tcl_Size
 Tcl_Read(
     Tcl_Channel chan,		/* The channel from which to read. */
     char *dst,			/* Where to store input read. */
-    Tcl_Size bytesToRead)		/* Maximum number of bytes to read. */
+    Tcl_Size bytesToRead)	/* Maximum number of bytes to read. */
 {
     Channel *chanPtr = (Channel *) chan;
     ChannelState *statePtr = chanPtr->state;
@@ -5760,7 +5760,7 @@ Tcl_Size
 Tcl_ReadRaw(
     Tcl_Channel chan,		/* The channel from which to read. */
     char *readBuf,		/* Where to store input read. */
-    Tcl_Size bytesToRead)		/* Maximum number of bytes to read. */
+    Tcl_Size bytesToRead)	/* Maximum number of bytes to read. */
 {
     Channel *chanPtr = (Channel *) chan;
     ChannelState *statePtr = chanPtr->state;
@@ -6063,10 +6063,21 @@ DoReadChars(
 	}
 
 	if (copiedNow < 0) {
-	    if (GotFlag(statePtr, CHANNEL_EOF) || 
-	        GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
+	    /*
+	     * copiedNow < 0 => no characters decoded in this iteration *AND*
+	     * no source bytes consumed.  This can happen if additional data
+	     * needed to decode the next character or an invalid byte sequence
+	     * is encountered before any data was successfully decoded.
+	     * If at EOF, no additional data is available. If an encoding
+	     * error is present, no progress can be made even if more data
+	     * is available (Bug 73bb42fb3f). Either way need to break out
+	     * of the loop.
+	     */
+	    if (GotFlag(statePtr, CHANNEL_EOF)
+		    || GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) {
 		break;
 	    }
+
 	    if ((GotFlag(statePtr, CHANNEL_NONBLOCKING) || allowShortReads)
 		    && GotFlag(statePtr, CHANNEL_BLOCKED)) {
 		break;
@@ -6823,7 +6834,7 @@ Tcl_Size
 Tcl_Ungets(
     Tcl_Channel chan,		/* The channel for which to add the input. */
     const char *str,		/* The input itself. */
-    Tcl_Size len,			/* The length of the input. */
+    Tcl_Size len,		/* The length of the input. */
     int atEnd)			/* If non-zero, add at end of queue; otherwise
 				 * add at head of queue. */
 {
@@ -7796,7 +7807,7 @@ Tcl_ChannelBuffered(
 void
 Tcl_SetChannelBufferSize(
     Tcl_Channel chan,		/* The channel whose buffer size to set. */
-    Tcl_Size sz)			/* The size to set. */
+    Tcl_Size sz)		/* The size to set. */
 {
     ChannelState *statePtr;	/* State of real channel structure. */
 
@@ -8870,7 +8881,7 @@ Tcl_CreateChannelHandler(
 				 * handler. */
     Tcl_ChannelProc *proc,	/* Procedure to call for each selected
 				 * event. */
-    void *clientData)	/* Arbitrary data to pass to proc. */
+    void *clientData)		/* Arbitrary data to pass to proc. */
 {
     ChannelHandler *chPtr;
     Channel *chanPtr = (Channel *) chan;
@@ -8942,7 +8953,7 @@ Tcl_DeleteChannelHandler(
     Tcl_Channel chan,		/* The channel for which to remove the
 				 * callback. */
     Tcl_ChannelProc *proc,	/* The procedure in the callback to delete. */
-    void *clientData)	/* The client data in the callback to
+    void *clientData)		/* The client data in the callback to
 				 * delete. */
 {
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -9148,7 +9159,7 @@ CreateScriptRecord(
 
 void
 TclChannelEventScriptInvoker(
-    void *clientData,	/* The script+interp record. */
+    void *clientData,		/* The script+interp record. */
     TCL_UNUSED(int) /*mask*/)
 {
     EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
@@ -10064,7 +10075,7 @@ static Tcl_Size
 DoRead(
     Channel *chanPtr,		/* The channel from which to read. */
     char *dst,			/* Where to store input read. */
-    Tcl_Size bytesToRead,		/* Maximum number of bytes to read. */
+    Tcl_Size bytesToRead,	/* Maximum number of bytes to read. */
     int allowShortReads)	/* Allow half-blocking (pipes,sockets) */
 {
     ChannelState *statePtr = chanPtr->state;

generic/tclIndexObj.c

@@ -388,8 +388,9 @@ UpdateStringOfIndex(
 {
     IndexRep *indexRep = (IndexRep *)TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1;
     const char *indexStr = EXPAND_OF(indexRep);
+    size_t len = strlen(indexStr);
 
-    Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
+    TclOOM(Tcl_InitStringRep(objPtr, indexStr, len), len+1);
 }
 
 /*

generic/tclInt.decls

@@ -683,6 +683,9 @@ declare 8 {
 declare 9 {
     TclFile TclpCreateTempFile(const char *contents)
 }
+declare 10 {
+    Tcl_Encoding TclWinGetUserEncoding(Tcl_Interp *interp)
+}
 declare 11 {
     void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan)
 }

generic/tclIntPlatDecls.h

@@ -547,7 +547,8 @@ EXTERN TclFile		TclpOpenFile(const char *fname, int mode);
 EXTERN Tcl_Size		TclpGetPid(Tcl_Pid pid);
 /* 9 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
-/* Slot 10 is reserved */
+/* 10 */
+EXTERN Tcl_Encoding	TclWinGetUserEncoding(Tcl_Interp *interp);
 /* 11 */
 EXTERN void		TclGetAndDetachPids(Tcl_Interp *interp,
 				Tcl_Channel chan);
@@ -600,7 +601,7 @@ typedef struct TclIntPlatStubs {
     TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
     Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */
     TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
-    void (*reserved10)(void);
+    Tcl_Encoding (*tclWinGetUserEncoding) (Tcl_Interp *interp); /* 10 */
     void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
     void (*reserved12)(void);
     void (*reserved13)(void);
@@ -654,7 +655,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 	(tclIntPlatStubsPtr->tclpGetPid) /* 8 */
 #define TclpCreateTempFile \
 	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */
-/* Slot 10 is reserved */
+#define TclWinGetUserEncoding \
+	(tclIntPlatStubsPtr->tclWinGetUserEncoding) /* 10 */
 #define TclGetAndDetachPids \
 	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */
 /* Slot 12 is reserved */
@@ -736,4 +738,12 @@ MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp,
 #   define TclpGetPid(pid) ((Tcl_Size)(pid))
 #endif
 
+#ifdef USE_TCL_STUBS
+/* Protect TclWinGetUserEncoding() for environments it doen't exist, e.g. Tcl 9.0.0/9.0.1 */
+#undef TclWinGetUserEncoding
+#define TclWinGetUserEncoding(interp) \
+	(tclIntPlatStubsPtr->tclWinGetUserEncoding ? tclIntPlatStubsPtr->tclWinGetUserEncoding(interp) : NULL)
+#endif
+
+
 #endif /* _TCLINTPLATDECLS */

generic/tclListObj.c

@@ -2664,14 +2664,14 @@ TclLindexFlat(
     Tcl_Size i;
 
     /* Handle AbstractList as special case */
-    if (TclObjTypeHasProc(listObj,indexProc)) {
+    if (indexCount == 1 && TclObjTypeHasProc(listObj,indexProc)) {
 	Tcl_Size listLen = TclObjTypeLength(listObj);
 	Tcl_Size index;
 	Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */
 	for (i=0 ; i<indexCount && listObj ; i++) {
 	    if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
-		    &index) == TCL_OK) {
-		// TODO: ???
+		    &index) != TCL_OK) {
+		return NULL;
 	    }
 	    if (i==0) {
 		if (TclObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) {
@@ -2684,6 +2684,13 @@ TclLindexFlat(
 		elemObj = e2Obj;
 	    }
 	}
+	if (elemObj == NULL) {
+	    /*
+	     * TclObjTypeIndex returns TCL_OK with NULL in elemObj if
+	     * index was out of bounds.
+	     */
+	    TclNewObj(elemObj);
+	}
 	Tcl_IncrRefCount(elemObj);
 	return elemObj;
     }
@@ -2720,6 +2727,7 @@ TclLindexFlat(
 		Tcl_IncrRefCount(listObj);
 	    } else {
 		Tcl_Obj *itemObj;
+		/* TODO - this will cause shimmering of inner abstract lists! */
 		/*
 		 * Must set the internal rep again because it may have been
 		 * changed by TclGetIntForIndexM. See test lindex-8.4.

generic/tclPlatDecls.h

@@ -219,9 +219,9 @@ extern const TclPlatStubs *tclPlatStubsPtr;
 #undef Tcl_WinTCharToUtf
 #ifdef _WIN32
 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
-		(TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
+	(TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
 #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
-		(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
+	Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
 #endif
 #endif
 

generic/tclResult.c

@@ -1034,7 +1034,7 @@ Tcl_GetReturnOptions(
 
     if (result == TCL_ERROR) {
 	if (!iPtr->errorInfo) {
-	    /* 
+	    /*
 	     * No errorLine without errorInfo, e. g. (re)thrown only message,
 	     * this shall also avoid transfer of errorLine (if goes to child
 	     * interp), because we have anyway nothing excepting message

generic/tclStrToD.c

@@ -40,7 +40,7 @@
  * Rounding controls. (Thanks a lot, Intel!)
  */
 
-#ifdef __i386
+#if defined(i386) || defined(__i386__) || defined(__i386) || defined(_M_IX86)
 /*
  * gcc on x86 needs access to rounding controls, because of a questionable
  * feature where it retains intermediate results as IEEE 'long double' values
@@ -1252,7 +1252,7 @@ TclParseNumber(
 	    }
 	}
 	if (endPtrPtr == NULL) {
-	    if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) {
+	    if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) {
 		status = TCL_ERROR;
 	    }
 	} else {
@@ -1822,6 +1822,8 @@ MakeHighPrecisionDouble(
     TCL_IEEE_DOUBLE_ROUNDING_DECL
 
     int machexp = 0;		/* Machine exponent of a power of 10. */
+    int shift, n;
+    mp_int bntmp;
 
     /*
      * With gcc on x86, the floating point rounding mode is double-extended.
@@ -1869,6 +1871,43 @@ MakeHighPrecisionDouble(
      * for overflow. Convert back to a double, and test for underflow.
      */
 
+    /*
+     * TCL bug ca62367d61: the following two if-conditions handle the case,
+     * if the mantissa is to long to be represented.
+     * Very high numbers are returned, if this is not handled
+     */
+
+
+    if (exponent < -511) {
+	if (mp_init_copy(&bntmp, significand) != MP_OKAY) {
+	    Tcl_Panic("initialization failure in MakeHighPrecisionDouble");
+	}
+	shift = -exponent - 511;
+	exponent += shift;
+	while (shift > 0) {
+	    n = (shift > 9) ? 9 : shift;
+	    if (mp_div_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp, NULL) != MP_OKAY) {
+		Tcl_Panic("initialization failure in MakeHighPrecisionDouble");
+	    }
+	    shift -= n;
+	}
+	significand = &bntmp;
+    } else if (exponent > 511) {
+	if (mp_init_copy(&bntmp, significand) != MP_OKAY) {
+	    Tcl_Panic("initialization failure in MakeHighPrecisionDouble");
+	}
+	shift = exponent - 511;
+	exponent -= shift;
+	while (shift > 0) {
+	    n = (shift > 9) ? 9 : shift;
+	    if (mp_mul_d(&bntmp, (mp_digit) pow10_wide[n], &bntmp) != MP_OKAY) {
+		Tcl_Panic("initialization failure in MakeHighPrecisionDouble");
+	    }
+	    shift -= n;
+	}
+	significand = &bntmp;
+    }
+
     retval = BignumToBiasedFrExp(significand, &machexp);
     retval = Pow10TimesFrExp(exponent, retval, &machexp);
     if (machexp > DBL_MAX_EXP*log2FLT_RADIX) {
@@ -1896,6 +1935,9 @@ MakeHighPrecisionDouble(
      */
 
   returnValue:
+    if (significand == &bntmp) {
+	mp_clear(&bntmp);
+    }
     if (signum) {
 	retval = -retval;
     }

generic/tclStringObj.c

@@ -724,7 +724,7 @@ Tcl_GetRange(
     Tcl_Size last)		/* Last index of the range. */
 {
     Tcl_Obj *newObjPtr;		/* The Tcl object to return that is the new
-					 * range. */
+				 * range. */
     String *stringPtr;
     Tcl_Size length = 0;
 
@@ -803,8 +803,8 @@ TclGetRange(
     Tcl_Size first,		/* First index of the range. */
     Tcl_Size last)		/* Last index of the range. */
 {
-    Tcl_Obj *newObjPtr;	 	/* The Tcl object to return that is the new
-					 * range. */
+    Tcl_Obj *newObjPtr;		/* The Tcl object to return that is the new
+				 * range. */
     Tcl_Size length = 0;
 
     if (first < 0) {

generic/tclStubInit.c

@@ -69,6 +69,10 @@
 # undef Tcl_WinConvertError
 # define Tcl_WinConvertError 0
 #endif
+#if !defined(_WIN32)
+# undef TclWinGetUserEncoding
+# define TclWinGetUserEncoding 0
+#endif
 #undef TclGetStringFromObj
 #if defined(TCL_NO_DEPRECATED)
 # define TclGetStringFromObj 0
@@ -692,7 +696,7 @@ static const TclIntPlatStubs tclIntPlatStubs = {
     TclpOpenFile, /* 7 */
     TclpGetPid, /* 8 */
     TclpCreateTempFile, /* 9 */
-    0, /* 10 */
+    TclWinGetUserEncoding, /* 10 */
     TclGetAndDetachPids, /* 11 */
     0, /* 12 */
     0, /* 13 */

generic/tclTestABSList.c

@@ -1047,7 +1047,7 @@ UpdateStringOfLgen(Tcl_Obj *objPtr)
     LgenSeries *lgenSeriesRepPtr;
     Tcl_Obj *element;
     Tcl_Size i;
-    size_t bytlen;
+    Tcl_Size bytlen;
     Tcl_Obj *tmpstr = Tcl_NewObj();
 
     lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1;
@@ -1062,8 +1062,9 @@ UpdateStringOfLgen(Tcl_Obj *objPtr)
 	}
     }
 
-    bytlen = Tcl_GetCharLength(tmpstr);
-    Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen);
+    char *str = Tcl_GetStringFromObj(tmpstr, &bytlen);
+
+    TclOOM(Tcl_InitStringRep(objPtr, str, bytlen), bytlen+1);
     Tcl_DecrRefCount(tmpstr);
 
     return;

macosx/tclMacOSXFCmd.c

@@ -687,7 +687,7 @@ UpdateStringOfOSType(
     Tcl_Encoding encoding;
     char src[5];
 
-    TclOOM(dst, size);
+    TclOOM(dst, size+1);
 
     src[0] = (char) (osType >> 24);
     src[1] = (char) (osType >> 16);

tests/clock.test

@@ -35530,7 +35530,7 @@ test clock-29.1813 {cache consistency when deriving localized formats, bug [2c0f
 	::msgcat::mcset en_US_roman_xx_yy DATE_FORMAT "%Y|%m|%d"
     }
     list [clock format 86400 -format %x -gmt 1 -locale en_US_roman] \
-         [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx] \
+	 [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx] \
 	 [clock format 86400 -format %x -gmt 1 -locale en_US_roman_xx_yy]
 } {01/02/1970 02.01.1970 1970|01|02}
 # END testcases29

tests/cmdAH.test

@@ -323,7 +323,7 @@ test cmdAH-4.1.1 {encoding} -returnCodes error -body {
 } -result {wrong # args: should be "encoding subcommand ?arg ...?"}
 test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body {
     encoding foo
-} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, or system}
+} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, system, or user}
 
 #
 # encoding system 4.2.*

tests/encoding.test

@@ -1150,6 +1150,16 @@ test encoding-30.3 {encoding convertfrom large strings > 4GB} -constraints {
     list [string length [set s [string repeat A 0x100000000]]] [string equal $s [encoding convertfrom ascii $s]]
 } -result {4294967296 1}
 
+# TIP 718 test
+test encoding-31.0 {encoding user} -constraints win -body {
+    package require registry
+    set acp cp[registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP]
+    if {$acp eq "cp65001"} {set acp utf-8}
+    string equal [encoding user] $acp
+} -cleanup {
+    unset acp
+} -result 1
+
 test encoding-bug-6a3e2cb0f0-1 {Bug [6a3e2cb0f0] - invalid bytes in escape encodings} -body {
     encoding convertfrom -profile tcl8 iso2022-jp x\x1B\x7Aaby
 } -result x\uFFFDy

tests/exec.test

@@ -29,7 +29,7 @@ testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}]
 if {[testConstraint win] && ![info exists ::env(CI)] &&
     [info exists ::env(LOCALAPPDATA)] &&
     [file exists [file join $::env(LOCALAPPDATA) "Microsoft" "WindowsApps" "winget.exe"]]} {
-        testConstraint haveWinget 1
+	testConstraint haveWinget 1
 }
 
 unset -nocomplain path
@@ -761,11 +761,11 @@ foreach cmdBuiltin {
     title type ver vol
 } {
     test auto_execok-$cmdBuiltin-1.0 "auto_execok $cmdBuiltin" \
-        -constraints win \
-        -body {
-            string equal [auto_execok $cmdBuiltin] \
-                "[file normalize $::env(COMSPEC)] /c $cmdBuiltin"
-        } -result 1
+	-constraints win \
+	-body {
+	    string equal [auto_execok $cmdBuiltin] \
+		"[file normalize $::env(COMSPEC)] /c $cmdBuiltin"
+	} -result 1
 }
 unset cmdBuiltin
 

tests/io.test

@@ -10018,7 +10018,7 @@ test io-bug-73bb43fb-4 {
       fconfigure stdout -translation binary
       puts -nonewline "START-"; flush stdout
       foreach {ch} [split [encoding convertto utf-8 \u30B3] ""] {; # 3 bytes E3 82 B3
-        puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100}
+	puts -nonewline $ch; flush stdout; if {$ch ne "\xB3"} {after 100}
       }
       puts -nonewline "-DONE"; flush stdout
     }]]

tests/lseq.test

@@ -1065,6 +1065,48 @@ test lseq-bug-f4a4bd7f1070-1 {} -body {
     set result
 } -result {1 {expected integer but got "3.1"} 0 {5 6 7} {0 1 2} {0 1 2} {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50} 0}
 
+test lseq-bug-7d3101bf28-0 {Bug 7d3101bf28 - crash on negative index} -body {
+    list \
+	[try [list lindex [lseq 10] -1]] \
+	[eval [list lindex [lseq 10] -1]]
+} -result {{} {}}
+
+test lseq-bug-7d3101bf28-1 {Bug 7d3101bf28 - crash on out of bounds index} -body {
+    list \
+	[try [list lindex [lseq 10] 10]] \
+	[eval [list lindex [lseq 10] 10]]
+} -result {{} {}}
+
+test lseq-bug-7d3101bf28-2 {Bug 7d3101bf28 - crash on error in index syntax} -body {
+    list \
+	[try [list lindex [lseq 10] foo]] \
+	[eval [list lindex [lseq 10] foo]]
+} -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} -returnCodes error
+
+test lseq-bug-452b103a74-0 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] 0 1
+} -result {}
+
+test lseq-bug-452b103a74-1 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] 0 end
+} -result 0
+
+test lseq-bug-452b103a74-2 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] {0 1}
+} -result {}
+
+test lseq-bug-452b103a74-3 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] {0 end}
+} -result 0
+
+test lseq-bug-452b103a74-4 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] 1 0
+} -result 1
+
+test lseq-bug-452b103a74-5 {Bug 452b103a74 - crash on nested indices} -body {
+    lindex [lseq 10] {end 0}
+} -result 9
+
 # cleanup
 ::tcltest::cleanupTests
 

tests/scan.test

@@ -880,6 +880,52 @@ test scan-14.2 {negative infinity} {
     return $d
 } -Inf
 
+test scan-15.1 {scan %g overflow for small numbers and big mantissa bug 42d14c495a} knownBug {
+    set result [list]
+    # xfail: n<num> = not expected at all, x<num> expected when unfixed
+    foreach {exp numdig ret xfail} {
+	-321  190 1.111647703142804724397279783953498087821e-321 n0
+	-321  191 1.111647703142804724397279783953498087821e-321 x1
+	-321  300 1.111647703142804724397279783953498087821e-321 x2
+	-321 1600 1.111647703142804724397279783953498087821e-321 x3
+	-400  110 0 n4
+	-400  111 0 n5
+	-400  300 0 n6
+	-221  290 1.111111111111110993454921768172890541494e-221 n7
+	-221  291 1.111111111111110993454921768172890541494e-221 x8
+	-221  400 1.111111111111110993454921768172890541494e-221 x9
+	-221 1600 1.111111111111110993454921768172890541494e-221 x10
+	-121  390 1.111111111111111182884141698869046969295e-121 n11
+	-121  391 1.111111111111111182884141698869046969295e-121 x12
+	-121  500 1.111111111111111182884141698869046969295e-121 x13
+	-121 1600 1.111111111111111182884141698869046969295e-121 x14
+	 308  202 1.111111111111111167662077577927612945036e+308 n15
+	 308  203 1.111111111111111167662077577927612945036e+308 n16
+	 308  300 1.111111111111111167662077577927612945036e+308 n17
+	 308 1600 1.111111111111111167662077577927612945036e+308 x18
+	 400  110 inf n19
+	 400  111 inf n20
+	 400  300 inf n21
+	 221  291 1.111111111111111207481621395250718679869e+221 n22
+	 221  292 1.111111111111111207481621395250718679869e+221 n23
+	 221  400 1.111111111111111207481621395250718679869e+221 n24
+         221 1600 1.111111111111111207481621395250718679869e+221 x25
+	 121  391 1.11111111111111112711771954138363761759e+121 n26
+	 121  392 1.11111111111111112711771954138363761759e+121 n27
+	 121  500 1.11111111111111112711771954138363761759e+121 n28
+	 121 1600 1.11111111111111112711771954138363761759e+121 x29
+    } {
+	set s 1.[string repeat 1 $numdig]e$exp
+	set d "no_scan"
+	scan $s %g d
+	set r [format %.40g $d]
+	if {$r ne $ret} {
+	    lappend result $xfail=[format %.40g $d]
+	}
+    }
+    set result
+} {}
+
 # TODO - also need to scan NaN's
 
 catch {rename int_range {}}

unix/Makefile.in

@@ -2410,7 +2410,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen
 	$(DIST_INSTALL_DATA) $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
 	$(DIST_INSTALL_DATA) $(TOP_DIR)/win/configure.ac \
 		$(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \
-		$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
+		$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 $(TOP_DIR)/win/tcl.dll.manifest.in \
 		$(TOP_DIR)/win/tclsh.exe.manifest.in $(TOP_DIR)/win/tclUuid.h.in \
 		$(TOP_DIR)/win/gitmanifest.in $(TOP_DIR)/win/svnmanifest.in \
 		$(TOP_DIR)/win/x86_64-w64-mingw32-nmakehlp.exe $(DISTDIR)/win

win/Makefile.in

@@ -171,6 +171,7 @@ SHARED_LIBRARIES	= $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
 STATIC_LIBRARIES	= $(TCL_LIB_FILE)
 
 TCLSH			= tclsh$(VER)${EXESUFFIX}
+TCLSHC			= tclsh$(VER)c${EXESUFFIX}
 WINE			= @WINE@
 CAT32			= cat32$(EXEEXT)
 
@@ -532,7 +533,7 @@ tcltest.sh: tcltest.cmd
 
 tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
 
-binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
+binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH) $(TCLSHC)
 
 winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} ${DDE_DLL_FILE8} ${REG_DLL_FILE8}
 
@@ -568,6 +569,15 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) ${TCL_ZIP_
 		cat ${TCL_ZIP_FILE} >> ${TCLSH}; \
 	fi
 
+$(TCLSHC): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclshc.$(RES) ${TCL_ZIP_FILE}
+	$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
+	tclshc.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
+	$(COPY) tcl.dll.manifest $(TCLSHC).manifest
+	@VC_MANIFEST_EMBED_EXE@
+	@if test "${ZIPFS_BUILD}" = "2" ; then \
+		cat ${TCL_ZIP_FILE} >> ${TCLSH}; \
+	fi
+
 cat32.$(OBJEXT): cat.c
 	$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
 
@@ -585,7 +595,7 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} ${DDE_OBJS} ${REG_OBJS}
 ${TCL_DLL_FILE}: ${TCL_LIB_FILE} ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ ${TCL_ZIP_FILE}
 	@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
 	@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest
+	$(COPY) tcl.dll.manifest ${TCL_DLL_FILE}.manifest
 	@VC_MANIFEST_EMBED_DLL@
 	@if test "${ZIPFS_BUILD}" = "1" ; then \
 		cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
@@ -603,24 +613,24 @@ endif
 
 ${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
 	@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
+	$(COPY) tcl.dll.manifest ${DDE_DLL_FILE}.manifest
 
 ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
 	@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest
+	$(COPY) tcl.dll.manifest ${REG_DLL_FILE}.manifest
 
 ${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinDde.$(OBJEXT)
 	@MAKE_DLL@ tcl8WinDde.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE8}.manifest
+	$(COPY) tcl.dll.manifest ${DDE_DLL_FILE8}.manifest
 
 ${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinReg.$(OBJEXT)
 	@MAKE_DLL@ -DTCL_MAJOR_VERSION=8 tcl8WinReg.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest
+	$(COPY) tcl.dll.manifest ${REG_DLL_FILE8}.manifest
 
 ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
 	@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
 	@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-	$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
+	$(COPY) tcl.dll.manifest ${TEST_DLL_FILE}.manifest
 
 ${TEST_EXE_FILE}: @LIBRARIES@ ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
 	@$(RM) ${TEST_EXE_FILE}
@@ -860,7 +870,7 @@ install-binaries: binaries
 		else true; \
 		fi; \
 	    done;
-	@for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH); \
+	@for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH) $(TCLSHC); \
 	    do \
 	    if [ -f $$i ]; then \
 		echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
@@ -1056,10 +1066,10 @@ cleanhelp:
 
 clean: cleanhelp clean-packages
 	$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
-	$(RM) $(TCLSH) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh
+	$(RM) $(TCLSH) $(TCLSHC) $(CAT32) $(TEST_EXE_FILE) $(TEST_DLL_FILE) tcltest.cmd tcltest.sh
 	# remaining binaries (inclusive manifests) by version/branch switch, but retain tclsh.exe.manifest (that created on configure phase)
 	find . -maxdepth 1 -type f -regex '\./tcl\(sh[^.]+\|test\|[^.]+.dll\)\.[^.]*\(\.manifest\)?' \
-		-a -not -name 'tclsh.exe.manifest' -exec rm {} \;
+		-a -not -name 'tclsh.exe.manifest' -a -not -name 'tcl.dll.manifest' -exec rm {} \;
 	$(RM) *.pch *.ilk *.pdb *.zip
 	$(RM) minizip${HOST_EXEEXT} *.${HOST_OBJEXT}
 	$(RMDIR) *.vfs

win/configure

@@ -6048,7 +6048,7 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d
 
 
 
-ac_config_files="$ac_config_files Makefile tclConfig.sh tclsh.exe.manifest"
+ac_config_files="$ac_config_files Makefile tclConfig.sh tclsh.exe.manifest tcl.dll.manifest"
 
 cat >confcache <<\_ACEOF
 # This file is a shell script that caches the results of configure
@@ -6754,6 +6754,7 @@ do
     "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
     "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;;
     "tclsh.exe.manifest") CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;;
+    "tcl.dll.manifest") CONFIG_FILES="$CONFIG_FILES tcl.dll.manifest" ;;
 
   *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;;
   esac

win/configure.ac

@@ -485,7 +485,7 @@ AC_SUBST(RC_DEFINE)
 AC_SUBST(RC_DEFINES)
 AC_SUBST(RES)
 
-AC_CONFIG_FILES([Makefile tclConfig.sh tclsh.exe.manifest])
+AC_CONFIG_FILES([Makefile tclConfig.sh tclsh.exe.manifest tcl.dll.manifest])
 AC_OUTPUT
 
 dnl Local Variables:

win/makefile.vc

@@ -145,7 +145,12 @@ RCFILE = tcl.rc
 # The tclsh executable without the embedded libzip. We need this
 # separately from tclsh to have dependency and build order work right.
 # Ditto for the DLL and tcltest
+
+TCLSHCNAME       = $(PROJECT)sh$(VERSION)c$(SUFX).exe
+TCLSHC		= $(OUT_DIR)\$(TCLSHCNAME)
+
 TCLSHRAW=$(TCLSH:.exe=-raw.exe)
+TCLSHCRAW=$(TCLSHC:.exe=-raw.exe)
 TCLLIBRAW=$(TCLLIB:.dll=-raw.dll)
 
 # Tcl version info based on macros set up by rules.vc
@@ -226,7 +231,6 @@ TCLTESTRAW	= $(TCLTEST:.exe=-raw.exe)
 
 TCLSHOBJS = \
 	$(TMP_DIR)\tclAppInit.obj \
-	$(TMP_DIR)\tclsh.res
 
 TCLTESTOBJS = \
 	$(TMP_DIR)\tclTest.obj \
@@ -528,10 +532,11 @@ core:	    libtclzip
 	@$(COPY) /b "$(TCLLIBRAW)"+"$(TCLSCRIPTZIP)" "$(TCLLIB)"
 !endif
 
-shell:	    setup core $(TCLSH)
+shell:	    setup core $(TCLSH) $(TCLSHC)
 !if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
 shell:      libtclzip
 	@$(COPY) /b "$(TCLSHRAW)"+"$(TCLSCRIPTZIP)" "$(TCLSH)"
+	@$(COPY) /b "$(TCLSHCRAW)"+"$(TCLSCRIPTZIP)" "$(TCLSHC)"
 !endif
 
 dlls:	    setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll
@@ -590,7 +595,7 @@ $(TCLIMPLIB): $(TCLLIB)
 $(TCLSTUBLIB): $(TCLSTUBOBJS)
 	$(LIBCMD) -nodefaultlib $(TCLSTUBOBJS)
 
-$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
+$(TCLSH): $(TCLSHOBJS) $(TMP_DIR)\tclsh.res $(TCLSTUBLIB) $(TCLIMPLIB)
 	$(CONEXECMD) -stack:2300000 $**
 	copy $(TMP_DIR)\tclsh.exe.manifest $(TCLSH).manifest
 	$(_VC_MANIFEST_EMBED_EXE)
@@ -598,6 +603,14 @@ $(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
 	$(COPY) $@ $(TCLSHRAW)
 !endif
 
+$(TCLSHC): $(TCLSHOBJS) $(TMP_DIR)\tclshc.res $(TCLSTUBLIB) $(TCLIMPLIB)
+	$(CONEXECMD) -stack:2300000 $**
+	copy $(TMP_DIR)\tcl.dll.manifest $(TCLSHC).manifest
+	$(_VC_MANIFEST_EMBED_EXE)
+!if $(TCL_EMBED_SCRIPTS) && $(STATIC_BUILD)
+	$(COPY) $@ $(TCLSHCRAW)
+!endif
+
 
 $(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
 	$(CONEXECMD) -stack:2300000 $**
@@ -654,7 +667,7 @@ $(OUT_DIR)\tommath.lib:	$(TOMMATHDIR)\win64\tommath.lib
 	$(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib
 !endif
 
-$(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) dlls
+$(TCLSCRIPTZIP): $(TCLLIB) $(TCLSH) $(TCLSHC) dlls
 	@echo Building Tcl library zip file $(TCLSCRIPTZIP)
 	@set TCL_LIBRARY=$(ROOT:\=/)/library
 	@if exist "$(LIBTCLVFS)" $(RMDIR) "$(LIBTCLVFS)"
@@ -982,6 +995,12 @@ $(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in
 @TCL_WIN_VERSION@  $(DOTVERSION).0.0
 <<
 
+$(TMP_DIR)\tcl.dll.manifest: $(WIN_DIR)\tcl.dll.manifest.in
+	@nmakehlp -s << $** >$@
+@MACHINE@	  $(MACHINE:IX86=X86)
+@TCL_WIN_VERSION@  $(DOTVERSION).0.0
+<<
+
 #---------------------------------------------------------------------
 # Generate the source dependencies.  Having dependency rules will
 # improve incremental build accuracy without having to resort to a
@@ -1035,6 +1054,8 @@ $<
 
 $(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc
 
+$(TMP_DIR)\tclshc.res: $(TMP_DIR)\tcl.dll.manifest $(WIN_DIR)\tclshc.rc
+
 $(TMP_DIR)\tcltest.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tcltest.rc
 
 #---------------------------------------------------------------------

win/tcl.dll.manifest.in

@@ -0,0 +1,51 @@
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"
+	xmlns:asmv3="urn:schemas-microsoft-com:asm.v3">
+    <assemblyIdentity
+	    version="@TCL_WIN_VERSION@"
+	    processorArchitecture="@MACHINE@"
+	    name="Tcl.tclsh"
+	    type="win32"
+	/>
+    <description>Tcl command line shell (tclsh)</description>
+    <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3">
+	<security>
+	    <requestedPrivileges>
+		<requestedExecutionLevel
+			level="asInvoker"
+			uiAccess="false"
+		    />
+	    </requestedPrivileges>
+	</security>
+    </trustInfo>
+    <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1">
+	<application>
+	    <!-- Windows 10 -->
+	    <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}"/>
+	    <!-- Windows 8.1 -->
+	    <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/>
+	    <!-- Windows 8 -->
+	    <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/>
+	    <!-- Windows 7 -->
+	    <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/>
+	</application>
+    </compatibility>
+    <asmv3:application>
+	<asmv3:windowsSettings
+		xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
+	    <dpiAware>true</dpiAware>
+	</asmv3:windowsSettings>
+    </asmv3:application>
+    <dependency>
+	<dependentAssembly>
+	    <assemblyIdentity
+		    type="win32"
+		    name="Microsoft.Windows.Common-Controls"
+		    version="6.0.0.0"
+		    processorArchitecture="@MACHINE@"
+		    publicKeyToken="6595b64144ccf1df"
+		    language="*"
+		/>
+	</dependentAssembly>
+    </dependency>
+</assembly>

win/tcl.rc

@@ -1,3 +1,4 @@
+//
 // Version Resource Script
 //
 

win/tclWinInit.c

@@ -35,6 +35,12 @@ typedef struct {
     WORD wReserved;
 } OemId;
 
+typedef struct {
+    Tcl_Encoding userEncoding;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
 /*
  * The following arrays contain the human readable strings for the
  * processor values.
@@ -63,6 +69,62 @@ static ProcessGlobalValue defaultLibraryDir =
 	{0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
 static ProcessGlobalValue sourceLibraryDir =
 	{0, 0, NULL, NULL, InitializeSourceLibraryDir, NULL, NULL};
+
+
+/*
+ * TclpGetWindowsVersionOnce --
+ *
+ *	Callback to retrieve Windows version information. To be invoked only
+ *	through InitOnceExecuteOnce for thread safety.
+ *
+ * Results:
+ *	None.
+ */
+static BOOL CALLBACK TclpGetWindowsVersionOnce(
+    TCL_UNUSED(PINIT_ONCE),
+    TCL_UNUSED(PVOID),
+    PVOID *lpContext)
+{
+    typedef int(__stdcall getVersionProc)(void *);
+    static OSVERSIONINFOW osInfo;
+
+    /*
+     * GetVersionExW will not return the "real" Windows version so use
+     * RtlGetVersion if available and falling back.
+     */
+    HMODULE handle = GetModuleHandleW(L"NTDLL");
+    getVersionProc *getVersion =
+	(getVersionProc *)(void *)GetProcAddress(handle, "RtlGetVersion");
+
+    osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+    if (getVersion == NULL || getVersion(&osInfo)) {
+	if (!GetVersionExW(&osInfo)) {
+	    /* Should never happen but ...*/
+	    return FALSE;
+	}
+    }
+    *lpContext = (LPVOID)&osInfo;
+    return TRUE;
+}
+
+/*
+ * TclpGetWindowsVersion --
+ *
+ *	Returns a pointer to the OSVERSIONINFOW structure containing the
+ *	version information for the current Windows version.
+ *
+ * Results:
+ *	Pointer to OSVERSIONINFOW structure.
+ */
+static const OSVERSIONINFOW *TclpGetWindowsVersion(void)
+{
+    static INIT_ONCE osInfoOnce = INIT_ONCE_STATIC_INIT;
+    OSVERSIONINFOW *osInfoPtr = NULL;
+    BOOL result = InitOnceExecuteOnce(
+	&osInfoOnce, TclpGetWindowsVersionOnce, NULL, (LPVOID *)&osInfoPtr);
+    return result ? osInfoPtr : NULL;
+}
+
 
 /*
  *---------------------------------------------------------------------------
@@ -397,11 +459,62 @@ TclpSetInitialEncodings(void)
     Tcl_DStringFree(&encodingName);
 }
 
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinGetUserEncoding --
+ *
+ *	Determines the encoding corresponding to the GetACP() call.
+ *	Since GetACP() cannot be thrusted, poke the
+ *	value from the registry directly.
+ *
+ * Results:
+ *	The found encoding. Or NULL if the encoding cannot be found.
+ *
+ * Side effects:
+ *	The returned encoding is valid until a future TclWinGetUserEncoding()
+ *	call determines that the ACP encoding changed. That should never happen.
+ *
+ *---------------------------------------------------------------------------
+ */
+Tcl_Encoding
+TclWinGetUserEncoding(Tcl_Interp *interp)
+{
+    WCHAR buf[32] = L"cp";
+
+    HKEY hKey;
+    DWORD type = -1;
+    DWORD size=sizeof(buf) - 2;
+    Tcl_DString ds;
+    RegOpenKeyExW(HKEY_LOCAL_MACHINE, L"SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage",
+	    0, KEY_READ, &hKey);
+    RegQueryValueExW(hKey, L"ACP", NULL, &type, (BYTE *)&buf[2], &size);
+    RegCloseKey(hKey);
+
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+    if (!wcscmp(buf, L"cp65001")) {
+	wcscpy(buf, L"utf-8");
+    }
+    Tcl_DStringInit(&ds);
+    Tcl_WCharToUtfDString(buf, -1, &ds);
+    if (!tsdPtr->userEncoding
+	    || strcmp(Tcl_GetEncodingName(tsdPtr->userEncoding), Tcl_DStringValue(&ds))) {
+	if (tsdPtr->userEncoding) {
+	    Tcl_FreeEncoding(tsdPtr->userEncoding);
+	}
+	tsdPtr->userEncoding = Tcl_GetEncoding(interp, Tcl_DStringValue(&ds));
+    }
+    Tcl_DStringFree(&ds);
+    return tsdPtr->userEncoding;
+}
+
 const char *
 Tcl_GetEncodingNameFromEnvironment(
     Tcl_DString *bufPtr)
 {
-    UINT acp = GetACP();
+    const OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion();
+    UINT acp = (!osInfoPtr || osInfoPtr->dwBuildNumber < 18362)
+	    ? GetACP() : CP_UTF8;
 
     Tcl_DStringInit(bufPtr);
     if (acp == CP_UTF8) {
@@ -409,7 +522,7 @@ Tcl_GetEncodingNameFromEnvironment(
     } else {
 	Tcl_DStringSetLength(bufPtr, 2 + TCL_INTEGER_SPACE);
 	snprintf(Tcl_DStringValue(bufPtr), 2 + TCL_INTEGER_SPACE, "cp%d",
-		GetACP());
+		acp);
 	Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
     }
     return Tcl_DStringValue(bufPtr);
@@ -577,7 +690,7 @@ Tcl_Size
 TclpFindVariable(
     const char *name,		/* Name of desired environment variable
 				 * (UTF-8). */
-    Tcl_Size *lengthPtr)		/* Used to return length of name (for
+    Tcl_Size *lengthPtr)	/* Used to return length of name (for
 				 * successful searches) or number of non-NULL
 				 * entries in environ (for unsuccessful
 				 * searches). */

win/tclshc.rc

@@ -0,0 +1,75 @@
+//
+// Version Resource Script
+//
+
+#include <winver.h>
+#include <tcl.h>
+
+//
+// build-up the name suffix that defines the type of build this is.
+//
+#if STATIC_BUILD
+#define SUFFIX_STATIC	    "s"
+#else
+#define SUFFIX_STATIC	    ""
+#endif
+
+#if DEBUG && !UNCHECKED
+#define SUFFIX_DEBUG	    "g"
+#else
+#define SUFFIX_DEBUG	    ""
+#endif
+
+#define SUFFIX		    SUFFIX_STATIC SUFFIX_DEBUG
+
+
+LANGUAGE 0x9, 0x1	/* LANG_ENGLISH, SUBLANG_DEFAULT */
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION	TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
+ PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
+ FILEFLAGSMASK	0x3fL
+#ifdef DEBUG
+ FILEFLAGS	VS_FF_DEBUG
+#else
+ FILEFLAGS	0x0L
+#endif
+ FILEOS	VOS__WINDOWS32
+ FILETYPE	VFT_APP
+ FILESUBTYPE	0x0L
+BEGIN
+    BLOCK "StringFileInfo"
+    BEGIN
+        BLOCK "040904b0"
+        BEGIN
+            VALUE "FileDescription", "Tclsh Application\0"
+            VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0"
+            VALUE "FileVersion", TCL_PATCH_LEVEL
+            VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0"
+            VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
+            VALUE "ProductVersion", TCL_PATCH_LEVEL
+        END
+    END
+    BLOCK "VarFileInfo"
+    BEGIN
+        VALUE "Translation", 0x409, 1200
+    END
+END
+
+//
+// Icon
+//
+
+tclsh                      ICON    DISCARDABLE     "tclsh.ico"
+
+//
+// This is needed for Windows 8.1 onwards.
+//
+
+#ifndef RT_MANIFEST
+#define RT_MANIFEST     24
+#endif
+#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID
+#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1
+#endif
+CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tcl.dll.manifest"