Merge 9.0 - Fix [87b69745be] - move zipfs encoding initialization outside of interp creation. Avoid unnecessary file system epoch bump.

5 files changed, 130 insertions, 86 deletions

diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 418317f..c3119dc 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -969,9 +969,11 @@ Tcl_GetEncodingNulLength(
  *	unless interp was NULL.
  *
  * Side effects:
- *	The reference count of the new system encoding is incremented. The
- *	reference count of the old system encoding is decremented and it may
- *	be freed. All VFS cached information is invalidated.
+ *	If the passed encoding is the same as the current system
+ *	encoding, the call is effectively a no-op. Otherwise, the reference
+ *	count of the new system encoding is incremented. The reference count
+ *	of the old system encoding is decremented and it may be freed. All
+ *	VFS cached information is invalidated.
  *
  *------------------------------------------------------------------------
  */
@@ -983,25 +985,34 @@ Tcl_SetSystemEncoding(
 				 * to reset to default encoding. */
 {
     Tcl_Encoding encoding;
-    Encoding *encodingPtr;
 
-    if (!name || !*name) {
-	Tcl_MutexLock(&encodingMutex);
-	encoding = defaultEncoding;
-	encodingPtr = (Encoding *) encoding;
-	encodingPtr->refCount++;
-	Tcl_MutexUnlock(&encodingMutex);
+    Tcl_MutexLock(&encodingMutex);
+    if (name == NULL || name[0] == '\0') {
+        if (defaultEncoding == systemEncoding) {
+            Tcl_MutexUnlock(&encodingMutex);
+            return TCL_OK;
+        }
+        encoding = defaultEncoding;
+        ((Encoding *)encoding)->refCount += 1;
     } else {
 	encoding = Tcl_GetEncoding(interp, name);
+        if (encoding == systemEncoding) {
+            FreeEncoding(encoding);
+            Tcl_MutexUnlock(&encodingMutex);
+            return TCL_OK;
+        }
 	if (encoding == NULL) {
+            Tcl_MutexUnlock(&encodingMutex);
 	    return TCL_ERROR;
 	}
     }
 
-    Tcl_MutexLock(&encodingMutex);
+    assert(encoding != systemEncoding);
     FreeEncoding(systemEncoding);
     systemEncoding = encoding;
     Tcl_MutexUnlock(&encodingMutex);
+
+    /* Checks above ensure this is only called when system encoding changes */
     Tcl_FSMountsChanged(NULL);
 
     return TCL_OK;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 84942db..1efb1f2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3697,6 +3697,7 @@ MODULE_SCOPE void	TclErrorStackResetIf(Tcl_Interp *interp,
 MODULE_SCOPE int	TclZipfs_Init(Tcl_Interp *interp);
 MODULE_SCOPE int	TclIsZipfsPath(const char *path);
 MODULE_SCOPE void	TclZipfsFinalize(void);
+MODULE_SCOPE int 	TclZipfsLocateTclLibrary(void);
 
 /*
  * Many parsing tasks need a common definition of whitespace.
diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c
index 2ec0ec4..ca0cd30 100644
--- a/generic/tclZipfs.c
+++ b/generic/tclZipfs.c
@@ -414,7 +414,6 @@ static int		InitWritableChannel(Tcl_Interp *interp,
 static int		ListMountPoints(Tcl_Interp *interp);
 static int		ContainsMountPoint(const char *path, int pathLen);
 static void		CleanupMount(ZipFile *zf);
-static Tcl_Obj *	ScriptLibrarySetup(const char *dirName);
 static void		SerializeCentralDirectoryEntry(
 			    const unsigned char *start,
 			    const unsigned char *end, unsigned char *buf,
@@ -647,6 +646,13 @@ ZipWriteShort(
 }
 
 /*
+ * Need a separate mutex for locating libraries because the search calls
+ * TclZipfs_Mount which takes out a write lock on the ZipFSMutex. Since
+ * those cannot be nested, we need a separate mutex.
+ */
+TCL_DECLARE_MUTEX(ZipFSLocateLibMutex)
+
+/*
  *-------------------------------------------------------------------------
  *
  * ReadLock, WriteLock, Unlock --
@@ -4277,49 +4283,23 @@ ZipFSListObjCmd(
 }
 
 /*
- *-------------------------------------------------------------------------
- *
- * TclZipfs_TclLibrary --
+ * TclZipfsLocateTclLibrary --
  *
- *	This procedure gets (and possibly finds) the root that Tcl's library
- *	files are mounted under.
+ *	This procedure locates the root that Tcl's library files are mounted
+ *	under if they are under a zipfs file system.
  *
  * Results:
- *	A Tcl object holding the location (with zero refcount), or NULL if no
- *	Tcl library can be found.
+ *	TCL_OK if the library was found, TCL_ERROR otherwise.
  *
  * Side effects:
- *	May initialise the cache of where such library files are to be found.
- *	This cache is never cleared.
+ *	Initializes the global variable zipfs_literal_tcl_library. Will
+ *	never be cleared.
  *
  *-------------------------------------------------------------------------
  */
 
-/* Utility routine to centralize housekeeping */
-static Tcl_Obj *
-ScriptLibrarySetup(
-    const char *dirName)
-{
-    Tcl_Obj *libDirObj = Tcl_NewStringObj(dirName, -1);
-    Tcl_Obj *subDirObj, *searchPathObj;
-
-    TclNewLiteralStringObj(subDirObj, "encoding");
-    Tcl_IncrRefCount(subDirObj);
-    TclNewObj(searchPathObj);
-    Tcl_ListObjAppendElement(NULL, searchPathObj,
-	    Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
-    Tcl_DecrRefCount(subDirObj);
-    Tcl_IncrRefCount(searchPathObj);
-    Tcl_SetEncodingSearchPath(searchPathObj);
-    Tcl_DecrRefCount(searchPathObj);
-    /* Bug [fccb9f322f]. Reinit system encoding after setting search path */
-    TclpSetInitialEncodings();
-    zipfs_tcl_library_init = 1;
-    return libDirObj;
-}
-
-Tcl_Obj *
-TclZipfs_TclLibrary(void)
+int
+TclZipfsLocateTclLibrary(void)
 {
     Tcl_Obj *vfsInitScript;
     int found;
@@ -4330,37 +4310,33 @@ TclZipfs_TclLibrary(void)
     char dllName[(MAX_PATH + LIBRARY_SIZE) * 3];
 #endif /* _WIN32 */
 
-    /*
-     * Use the cached value if that has been set; we don't want to repeat the
-     * searching and mounting. Even if it is not found, see [62019f8aa9f5ec73].
-     */
-    
     if (zipfs_tcl_library_init) {
-	if (!zipfs_literal_tcl_library) {
-	    return NULL;
-	}
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;
     }
 
-    /*
-     * Look for the library file system within the executable.
-     */
+    Tcl_MutexLock(&ZipFSLocateLibMutex);
+    if (zipfs_tcl_library_init) {
+	/* Some other thread won the race */
+	Tcl_MutexUnlock(&ZipFSLocateLibMutex);
+	return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;
+    }
 
-    vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl",
-	    -1);
+    /* Look for the library file system within the executable. */
+    vfsInitScript =
+	Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", -1);
     Tcl_IncrRefCount(vfsInitScript);
     found = Tcl_FSAccess(vfsInitScript, F_OK);
     Tcl_DecrRefCount(vfsInitScript);
     if (found == TCL_OK) {
 	zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library";
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	goto unlock_and_return;
     }
 
     /*
-     * Look for the library file system within the DLL/shared library.  Note
-     * that we must mount the zip file and dll before releasing to search.
+     * Look for the library file system within the DLL/shared
+     * library.  Note that we must mount the zip file and dll before
+     * releasing to search.
      */
-
 #if !defined(STATIC_BUILD)
 #if defined(_WIN32) || defined(__CYGWIN__)
     hModule = (HMODULE)TclWinGetTclInstance();
@@ -4372,34 +4348,53 @@ TclZipfs_TclLibrary(void)
 #endif
 
     if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) {
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	goto unlock_and_return;
     }
 #elif !defined(NO_DLFCN_H)
     Dl_info dlinfo;
     if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL)
 	    && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) {
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	goto unlock_and_return;
     }
 #else
     if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) {
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	goto unlock_and_return;
     }
 #endif /* _WIN32 */
 #endif /* !defined(STATIC_BUILD) */
 
+unlock_and_return:
+    zipfs_tcl_library_init = 1;
+    Tcl_MutexUnlock(&ZipFSLocateLibMutex);
+    return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclZipfs_TclLibrary --
+ *
+ *	This procedure gets the root that Tcl's library
+ *	files are mounted under if they are under a zipfs file system.
+ *
+ * Results:
+ *	A Tcl object holding the location (with zero refcount), or NULL if no
+ *	Tcl library can be found.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclZipfs_TclLibrary(void)
+{
     /*
-     * If anything set the cache (but subsequently failed) go with that
-     * anyway.
+     * Assumes TclZipfsLocateTclLibrary has already been called at startup
+     * through Tcl_InitSubsystems.
      */
-
+    assert(zipfs_tcl_library_init);
     if (zipfs_literal_tcl_library) {
-	return ScriptLibrarySetup(zipfs_literal_tcl_library);
+	return Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
     }
-    /* 
-     * No zipfs tcl-library, mark it to avoid performance penalty [62019f8aa9f5ec73],
-     * by future calls (child interpreters, threads, etc).
-     */
-    zipfs_tcl_library_init = 1;
     return NULL;
 }
 
@@ -6467,6 +6462,37 @@ TclZipfsFinalize(void)
 }
 
 /*
+ * TclZipfsInitEncodingDirs --
+ *
+ *	Sets the encoding directory search path to the encoding directory
+ *	under the tcl_library directory within a ZipFS mount. Overwrites the
+ *	previously set encoding search path so only to be called at
+ *	initialization.
+ */
+static int
+TclZipfsInitEncodingDirs(void)
+{
+    if (zipfs_literal_tcl_library == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_Obj *libDirObj = Tcl_NewStringObj(zipfs_literal_tcl_library, -1);
+    Tcl_Obj *subDirObj, *searchPathObj;
+
+    TclNewLiteralStringObj(subDirObj, "encoding");
+    Tcl_IncrRefCount(subDirObj);
+    TclNewObj(searchPathObj);
+    Tcl_ListObjAppendElement(NULL, searchPathObj,
+	    Tcl_FSJoinToPath(libDirObj, 1, &subDirObj));
+    Tcl_DecrRefCount(subDirObj);
+    Tcl_IncrRefCount(searchPathObj);
+    Tcl_SetEncodingSearchPath(searchPathObj);
+    Tcl_DecrRefCount(searchPathObj);
+    /* Reinit system encoding after setting search path */
+    TclpSetInitialEncodings();
+    return TCL_OK;
+}
+
+/*
  *-------------------------------------------------------------------------
  *
  * TclZipfs_AppHook --
@@ -6499,11 +6525,13 @@ TclZipfs_AppHook(
 #endif
     archive = Tcl_GetNameOfExecutable();
     TclZipfs_Init(NULL);
-
     /*
      * Look for init.tcl in one of the locations mounted later in this
-     * function.
+     * function. Errors ignored as other locations may be available.
      */
+    if (TclZipfsLocateTclLibrary() == TCL_OK) {
+	(void) TclZipfsInitEncodingDirs();
+    }
 
     if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) {
 	int found;
diff --git a/tests/encoding.test b/tests/encoding.test
index a13deab..90df0dc 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -1258,6 +1258,16 @@ test encoding-bug-7346adc50f-tcl8 {OOM on convertfrom truncated iso2022 - tcl8}
     encoding convertfrom -profile tcl8 iso2022-jp "\x1b\$B\$*;n\$"
 } -result \u304A\u8A66\uFFFD
 
+test encoding-dirs-bug-87b69745be {encoding dirs reset on interp creation} -setup {
+    set origEncodingDirs [encoding dirs]
+} -cleanup {
+    encoding dirs $origEncodingDirs
+    unset -nocomplain origEncodingDirs
+} -body {
+    encoding dirs [linsert [encoding dirs] end /temp]
+    interp delete [interp create]
+	encoding dirs
+} -result [linsert [encoding dirs] end /temp]
 
 # cleanup
 namespace delete ::tcl::test::encoding
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 899779c..2e797b7 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -123,18 +123,12 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup {
     puts $f {puts [encoding system]; exit}
     set enc [gets $f]
     close $f
-    set validEncodings [list euc-jp]
-    if {[string match HP-UX $tcl_platform(os)]} {
-	# Some older HP-UX systems need us to accept this as valid Bug 453883
-	# reports that newer HP-UX systems report euc-jp like everybody else.
-	lappend validEncodings shiftjis
-    }
-    expr {$enc ni $validEncodings}
+    set enc
 } -cleanup {
     unset -nocomplain env(LANG) env(LC_ALL)
     catch {set env(LC_ALL) $oldlc_all}
     catch {set env(TCL_LIBRARY) $oldtcl_library}
-} -result 0
+} -result {^(euc-jp|shiftjis)$} -match regexp
 
 test unixInit-4.1 {TclpSetVariables} {unix} {
     # just make sure they exist