TIP 716 accepted

12 files changed, 246 insertions, 37 deletions

diff --git a/doc/encoding.n b/doc/encoding.n
index 43da934..7789778 100644
--- a/doc/encoding.n
+++ b/doc/encoding.n
@@ -104,6 +104,14 @@ Returns a list of the names of encoding profiles. See \fBPROFILES\fR below.
 Set the system encoding to \fIencoding\fR. If \fIencoding\fR is
 omitted then the command returns the current system encoding.  The
 system encoding is used whenever Tcl passes strings to system calls.
+.TP
+\fBencoding user\fR
+.VS TIP716
+Returns the name of encoding as per the user's preferences. On Windows
+systems, this is based on the user's code page settings in the registry.
+On other platforms, the returned value is the same as returned by
+\fBencoding system\fR.
+.VE TIP716
 .\" Do not put .VS on whole section as that messes up the bullet list alignment
 .SH PROFILES
 .PP
diff --git a/doc/exec.n b/doc/exec.n
index 4992922..381b5cd 100644
--- a/doc/exec.n
+++ b/doc/exec.n
@@ -31,6 +31,12 @@ If the initial arguments to \fBexec\fR start with \fB\-\fR then
 they are treated as command-line switches and are not part
 of the pipeline specification.  The following switches are
 currently supported:
+.\" OPTION: -encoding
+.TP 13
+\fB\-encoding \fIencodingName\fR
+.
+Specifies the name of the encoding to use to decode the output of the first
+subprocess. Defaults to that returned by the \fBencoding system\fR command.
 .\" OPTION: -ignorestderr
 .TP 13
 \fB\-ignorestderr\fR
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index ea98a83..877b3bb 100644
--- a/generic/tclCmdAH.c
+++ b/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}
     };
 
@@ -829,6 +831,36 @@ EncodingSystemObjCmd(
 }
 
 /*
+ *-----------------------------------------------------------------------------
+ *
+ * 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;
+    }
+    Tcl_DString ds;
+    Tcl_GetEncodingNameForUser(&ds);
+    Tcl_DStringResult(interp, &ds);
+    return TCL_OK;
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * Tcl_ErrorObjCmd --
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 712447b..aefefee 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -910,11 +910,12 @@ Tcl_ExecObjCmd(
     int argc, background, i, index, keepNewline, result, skip, ignoreStderr;
     Tcl_Size length;
     static const char *const options[] = {
-	"-ignorestderr", "-keepnewline", "--", NULL
+	"-ignorestderr", "-keepnewline", "-encoding", "--", NULL
     };
     enum execOptionsEnum {
-	EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
+	EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_ENCODING, EXEC_LAST
     };
+    Tcl_Obj *encodingObj = NULL;
 
     /*
      * Check for any leading option arguments.
@@ -931,12 +932,24 @@ Tcl_ExecObjCmd(
 		TCL_EXACT, &index) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (index == EXEC_KEEPNEWLINE) {
+	if (index == EXEC_LAST) {
+	    skip++;
+	    break;
+	}
+	switch (index) {
+	case EXEC_KEEPNEWLINE:
 	    keepNewline = 1;
-	} else if (index == EXEC_IGNORESTDERR) {
+	    break;
+	case EXEC_IGNORESTDERR:
 	    ignoreStderr = 1;
-	} else {
-	    skip++;
+	    break;
+	case EXEC_ENCODING:
+	    if (++skip >= objc) {
+		Tcl_SetResult(interp, "No value given for option -encoding.",
+			TCL_STATIC);
+		return TCL_ERROR;
+	    }
+	    encodingObj = objv[skip];
 	    break;
 	}
     }
@@ -986,11 +999,6 @@ Tcl_ExecObjCmd(
 	return TCL_ERROR;
     }
 
-    /* Bug [0f1ddc0df7] - encoding errors - use replace profile */
-    if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) {
-	return TCL_ERROR;
-    }
-
     if (background) {
 	/*
 	 * Store the list of PIDs from the pipeline in interp's result and
@@ -1004,6 +1012,20 @@ Tcl_ExecObjCmd(
 	return TCL_OK;
     }
 
+    /* Bug [0f1ddc0df7] - encoding errors - use replace profile */
+    if (Tcl_SetChannelOption(interp, chan, "-profile", "replace") != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /* TIP 716 */
+    if (encodingObj) {
+	if (Tcl_SetChannelOption(
+		interp, chan, "-encoding", Tcl_GetString(encodingObj)) !=
+	    TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+
     TclNewObj(resultPtr);
     if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
 	if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9231087..5aa7980 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3117,7 +3117,16 @@ MODULE_SCOPE int	TclEncodingProfileNameToId(Tcl_Interp *interp,
 MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp,
 			    int profileId);
 MODULE_SCOPE void	TclGetEncodingProfiles(Tcl_Interp *interp);
-
+/* TIP 716 - MODULE_SCOPE for 9.0.2. Will be public in 9.1 */
+#ifdef _WIN32
+MODULE_SCOPE const char *Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr);
+#else
+static inline const char *
+Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr)
+{
+    return Tcl_GetEncodingNameFromEnvironment(bufPtr);
+}
+#endif
 /*
  * TIP #233 (Virtualized Time)
  * Data for the time hooks, if any.
diff --git a/tests/cmdAH.test b/tests/cmdAH.test
index 50e49e8..7b9e4f3 100644
--- a/tests/cmdAH.test
+++ b/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.*
diff --git a/tests/encoding.test b/tests/encoding.test
index b20b18d..dfc8dfb 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -12,7 +12,7 @@ if {"::tcltest" ni [namespace children]} {
     package require tcltest 2.5
     namespace import -force ::tcltest::*
 }
-
+source [file join [file dirname [info script]] tcltests.tcl]
 
 namespace eval ::tcl::test::encoding {
     variable x
@@ -1150,6 +1150,32 @@ 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 716 tests
+tcltests::testnumargs "encoding user" "" ""
+test encoding-31.0 {encoding user} -body {
+    encoding user
+} -result [expr {$::tcl_platform(platform) eq "windows" ? [tcltests::windowscodepage] : [encoding system]}]
+
+test encoding-31.1 {encoding system does not change encoding user} -setup {
+    set system [encoding system]
+    set user [encoding user]
+} -body {
+    encoding system ascii
+    list [encoding system] [string equal [encoding user] $user]
+} -cleanup {
+    encoding system $system
+    unset system
+    unset user
+} -result {ascii 1}
+
+test encoding-31.2 {encoding system on newer Windows always returns utf-8} -body {
+    string equal [encoding system] \
+        [expr {
+               [tcltests::windowsbuildnumber] > 18362 ?
+               "utf-8" : [tcltests::windowscodepage]
+           }]
+} -constraints win -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
diff --git a/tests/exec.test b/tests/exec.test
index 3225c6d..06d6bea 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -48,6 +48,11 @@ set path(echo2) [makeFile {
     puts stderr [lindex $argv 1]
     exit
 } echo2]
+set path(echobin) [makeFile {
+    fconfigure stdout -translation binary
+    puts -nonewline [binary decode hex [join $argv ""]]
+    exit
+} echobin]
 set path(cat) [makeFile {
     if {$argv eq ""} {
 	set argv -
@@ -568,7 +573,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body {
 } -returnCodes error -result {wrong # args: should be "exec ?-option ...? arg ?arg ...?"}
 test exec-14.3 {unknown switch} -constraints {exec} -body {
     exec -gorp
-} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --}
+} -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, -encoding, or --}
 test exec-14.4 {-- switch} -constraints {exec notValgrind} -body {
     exec -- -gorp
 } -returnCodes error -result {couldn't execute "-gorp": no such file or directory}
@@ -750,6 +755,15 @@ test exec-21.2 {exec encoding mismatch on stderr} -setup {
     list [catch {exec [info nameofexecutable] $path(script)} r] $r
 } -result [list 1 a\uFFFDb]
 
+# TIP 716 -encoding option
+test exec-22.0 {exec -encoding} -body {
+    set enc [expr {[encoding system] eq "utf-8" ? "iso2022-jp" : "utf-8"}]
+    exec -encoding $enc -- [interpreter] $path(echobin) [binary encode hex [encoding convertto $enc \u4e4e\u68d9]]
+} -result \u4e4e\u68d9
+test exec-22.1 {exec -encoding invalid encoding} -body {
+    exec -encoding nosuchencoding -- [interpreter] $path(echobin) abc
+} -result {unknown encoding "nosuchencoding"} -returnCodes error
+
 test exec-bug-4f0b5767ac {exec App Execution Alias} -constraints haveWinget -body {
     exec winget --info
 } -result "Windows Package Manager*" -match glob
diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl
index 43f0f60..73080f0 100644
--- a/tests/tcltests.tcl
+++ b/tests/tcltests.tcl
@@ -116,6 +116,25 @@ namespace eval ::tcltests {
 		-result $message -returnCodes error \
 		{*}$args
 	}
+
+        # Return Windows version as FULLVERSION MAJOR MINOR BUILD REVISION
+        if {$::tcl_platform(platform) eq "windows"} {
+            proc windowsversion {} {
+                set ver [regexp -inline {(\d+).(\d+).(\d+).(\d+)} [exec {*}[auto_execok ver]]]
+                proc windowsversion {} [list return $ver]
+                return [windowsversion]
+            }
+            proc windowsbuildnumber {} {
+                return [lindex [windowsversion] 3]
+            }
+            proc windowscodepage {} {
+                # Note we cannot use result of chcp because that returns OEM code page.
+                package require registry
+                set cp [registry get HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage ACP]
+                proc windowscodepage {} "return cp$cp"
+                return [windowscodepage]
+            }
+        }
     }
 
     init
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 39c04a2..b3ea057 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -12,6 +12,7 @@
  */
 
 #include "tclWinInt.h"
+#include <assert.h>
 #include <winnt.h>
 #include <winbase.h>
 #include <lmcons.h>
@@ -119,7 +120,74 @@ static const OSVERSIONINFOW *TclpGetWindowsVersion(void)
     return result ? osInfoPtr : NULL;
 }
 
-
+/*
+ * TclpGetCodePageOnce --
+ *
+ *	Callback to retrieve user code page. To be invoked only
+ *	through InitOnceExecuteOnce for thread safety.
+ *
+ * Results:
+ *	None.
+ */
+static BOOL CALLBACK
+TclpGetCodePageOnce(
+    TCL_UNUSED(PINIT_ONCE),
+    TCL_UNUSED(PVOID),
+    PVOID *lpContext)
+{
+    static char codePage[20];
+    codePage[0] = 'c';
+    codePage[1] = 'p';
+    DWORD size = sizeof(codePage) - 2;
+
+    /*
+     * When retrieving code page from registry,
+     *  - use ANSI API's since all values will be ASCII and saves conversion
+     *  - use RegGetValue, not RegQueryValueEx, since the latter does not
+     *    guarantee the value is null terminated
+     *  - added bonus, RegGetValue is much more convenient to use
+     */
+    if (RegGetValueA(HKEY_LOCAL_MACHINE,
+	    "SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage",
+	    "ACP", RRF_RT_REG_SZ, NULL, codePage+2,
+	    &size) != ERROR_SUCCESS) {
+	/* On failure, fallback to GetACP() */
+	UINT acp = GetACP();
+	snprintf(codePage, sizeof(codePage), "cp%u", acp);
+    }
+    if (strcmp(codePage, "cp65001") == 0) {
+	strcpy(codePage, "utf-8");
+    }
+    *lpContext = (LPVOID)&codePage[0];
+    return TRUE;
+}
+
+/*
+ * TclpGetCodePage --
+ *
+ *  Returns a pointer to the string identifying the user code page.
+ *
+ *  For consistency with Windows, which caches the code page at program
+ *  startup, the code page is not updated even if the value in the registry
+ *  changes. (This is similar to environment variables.)
+ */
+static const char *
+TclpGetCodePage(void)
+{
+    static INIT_ONCE codePageOnce = INIT_ONCE_STATIC_INIT;
+    const char *codePagePtr = NULL;
+    BOOL result = InitOnceExecuteOnce(
+	&codePageOnce, TclpGetCodePageOnce, NULL, (LPVOID *)&codePagePtr);
+#ifdef NDEBUG
+    (void) result; /* Keep gcc unused variable quiet */
+#else
+    assert(result == TRUE);
+#endif
+    assert(codePagePtr != NULL);
+    return codePagePtr;
+}
+
+
 /*
  *---------------------------------------------------------------------------
  *
@@ -162,8 +230,11 @@ TclpInitPlatform(void)
 
     TclWinInit(GetModuleHandleW(NULL));
 #endif
+
+    /* Initialize code page once at startup, will not be updated */
+    (void)TclpGetCodePage();
 }
-
+
 /*
  *-------------------------------------------------------------------------
  *
@@ -454,25 +525,31 @@ TclpSetInitialEncodings(void)
 }
 
 const char *
+Tcl_GetEncodingNameForUser(Tcl_DString *bufPtr)
+{
+    Tcl_DStringInit(bufPtr);
+    Tcl_DStringAppend(bufPtr, TclpGetCodePage(), -1);
+    return Tcl_DStringValue(bufPtr);
+}
+
+const char *
 Tcl_GetEncodingNameFromEnvironment(
     Tcl_DString *bufPtr)
 {
     const OSVERSIONINFOW *osInfoPtr = TclpGetWindowsVersion();
-    UINT acp = (!osInfoPtr || osInfoPtr->dwBuildNumber < 18362)
-	    ? GetACP() : CP_UTF8;
-
-    Tcl_DStringInit(bufPtr);
-    if (acp == CP_UTF8) {
+    /*
+     * TIP 716 - for Build 18362 or higher, force utf-8. Note Windows build
+     * numbers always increase, so no need to check major / minor versions.
+     */
+    if (osInfoPtr && osInfoPtr->dwBuildNumber >= 18362) {
+	Tcl_DStringInit(bufPtr);
 	Tcl_DStringAppend(bufPtr, "utf-8", 5);
+	return Tcl_DStringValue(bufPtr);
     } else {
-	Tcl_DStringSetLength(bufPtr, 2 + TCL_INTEGER_SPACE);
-	snprintf(Tcl_DStringValue(bufPtr), 2 + TCL_INTEGER_SPACE, "cp%d",
-		acp);
-	Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
+	return Tcl_GetEncodingNameForUser(bufPtr);
     }
-    return Tcl_DStringValue(bufPtr);
 }
-
+
 const char *
 TclpGetUserName(
     Tcl_DString *bufferPtr)	/* Uninitialized or free DString filled with
@@ -493,7 +570,7 @@ TclpGetUserName(
     }
     return Tcl_DStringValue(bufferPtr);
 }
-
+
 /*
  *---------------------------------------------------------------------------
  *
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 72e1e83..005fb37 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -444,9 +444,9 @@ TestplatformChmod(
     res = -1; /* Assume failure */
 
     Tcl_DStringInit(&ds);
-    Tcl_UtfToExternalDString(NULL, nativePath, -1, &ds);
+    Tcl_UtfToChar16DString(nativePath, -1, &ds);
 
-    attr = GetFileAttributesA(Tcl_DStringValue(&ds));
+    attr = GetFileAttributesW((WCHAR *)Tcl_DStringValue(&ds));
     if (attr == 0xFFFFFFFF) {
 	goto done; /* Not found */
     }
@@ -586,7 +586,7 @@ TestplatformChmod(
      * to remove inherited ACL (we need to overwrite the default ACL's in this case)
      */
 
-    if (SetNamedSecurityInfoA((LPSTR)Tcl_DStringValue(&ds), SE_FILE_OBJECT,
+    if (SetNamedSecurityInfoW((LPWSTR)Tcl_DStringValue(&ds), SE_FILE_OBJECT,
 	    DACL_SECURITY_INFORMATION | PROTECTED_DACL_SECURITY_INFORMATION,
 	    NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
 	res = 0;
@@ -608,7 +608,7 @@ TestplatformChmod(
 
     if (res == 0) {
 	/* Run normal chmod command */
-	res = _chmod(Tcl_DStringValue(&ds), pmode);
+	res = _wchmod((WCHAR*)Tcl_DStringValue(&ds), pmode);
     }
     Tcl_DStringFree(&ds);
     return res;
diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in
index dc652e6..dd8a7c5 100644
--- a/win/tclsh.exe.manifest.in
+++ b/win/tclsh.exe.manifest.in
@@ -35,10 +35,6 @@
 		xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
 	    <dpiAware>true</dpiAware>
 	</asmv3:windowsSettings>
-	<asmv3:windowsSettings
-		xmlns="http://schemas.microsoft.com/SMI/2019/WindowsSettings">
-	    <activeCodePage>UTF-8</activeCodePage>
-	</asmv3:windowsSettings>
     </asmv3:application>
     <dependency>
 	<dependentAssembly>