From a37a480bf571d7a03726479944401d2c7bafbca2 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 31 Jul 2025 13:57:58 +0000 Subject: Add test for [87b69745be]. --- tests/encoding.test | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/tests/encoding.test b/tests/encoding.test index 66a60a8..79169cd 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -1248,6 +1248,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 -- cgit v0.12 From 0da7d37ae9e40a473991c87155abf533ae5d45a0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Aug 2025 11:38:46 +0000 Subject: Move search of zipfs to process initialization, not interp initialization --- generic/tclInt.h | 1 + generic/tclZipfs.c | 47 ++++++++++++++++++++++++++++------------------- 2 files changed, 29 insertions(+), 19 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f088545..c227b0c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3733,6 +3733,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 503e22c..4853376 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4345,8 +4345,8 @@ ScriptLibrarySetup( return libDirObj; } -Tcl_Obj * -TclZipfs_TclLibrary(void) +int +TclZipfsLocateTclLibrary(void) { Tcl_Obj *vfsInitScript; int found; @@ -4357,17 +4357,7 @@ 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); - } + assert(!zipfs_tcl_library_init); /* * Look for the library file system within the executable. @@ -4380,7 +4370,8 @@ TclZipfs_TclLibrary(void) Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return ScriptLibrarySetup(zipfs_literal_tcl_library); + zipfs_tcl_library_init = 1; + return TCL_OK; } /* @@ -4399,17 +4390,20 @@ TclZipfs_TclLibrary(void) #endif if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { - return ScriptLibrarySetup(zipfs_literal_tcl_library); + zipfs_tcl_library_init = 1; + return TCL_OK; } #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); + zipfs_tcl_library_init = 1; + return TCL_OK; } #else if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - return ScriptLibrarySetup(zipfs_literal_tcl_library); + zipfs_tcl_library_init = 1; + return TCL_OK; } #endif /* _WIN32 */ #endif /* !defined(STATIC_BUILD) */ @@ -4420,13 +4414,27 @@ TclZipfs_TclLibrary(void) */ if (zipfs_literal_tcl_library) { - return ScriptLibrarySetup(zipfs_literal_tcl_library); + return TCL_OK; } /* * No zipfs tcl-library, mark it to avoid performance penalty [62019f8aa9f5ec73], * by future calls (child interpreters, threads, etc). */ zipfs_tcl_library_init = 1; + return TCL_ERROR; +} + +Tcl_Obj * +TclZipfs_TclLibrary(void) +{ + /* + * 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 NULL; } @@ -6529,8 +6537,9 @@ TclZipfs_AppHook( /* * Look for init.tcl in one of the locations mounted later in this - * function. + * function. Errors ignored as other locations may be available. */ + (void) TclZipfsLocateTclLibrary(); if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { int found; -- cgit v0.12 From b6b37b7c74507c13588740959a178a19f4290469 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Aug 2025 12:07:40 +0000 Subject: Delete dead code --- generic/tclZipfs.c | 60 +++++++++++++++--------------------------------------- 1 file changed, 16 insertions(+), 44 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 4853376..8eacf41 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, @@ -4303,48 +4302,6 @@ ZipFSListObjCmd( return TCL_OK; } -/* - *------------------------------------------------------------------------- - * - * TclZipfs_TclLibrary -- - * - * This procedure gets (and possibly finds) the root that Tcl's library - * files are mounted under. - * - * Results: - * A Tcl object holding the location (with zero refcount), or NULL if no - * Tcl library can be found. - * - * Side effects: - * May initialise the cache of where such library files are to be found. - * This cache is never 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; -} - int TclZipfsLocateTclLibrary(void) { @@ -4424,6 +4381,21 @@ TclZipfsLocateTclLibrary(void) return 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) { @@ -4433,7 +4405,7 @@ TclZipfs_TclLibrary(void) */ assert(zipfs_tcl_library_init); if (zipfs_literal_tcl_library) { - return ScriptLibrarySetup(zipfs_literal_tcl_library); + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); } return NULL; } -- cgit v0.12 From 4d20eb490b1a3c5c547b93f2f54fb0bd4a3df4f7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Aug 2025 14:01:28 +0000 Subject: Protect zipfs location with lock --- generic/tclZipfs.c | 77 ++++++++++++++++++++++++++++++++---------------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 8eacf41..7d3e6e8 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -646,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 -- @@ -4302,6 +4309,22 @@ ZipFSListObjCmd( return TCL_OK; } +/* + * TclZipfsLocateTclLibrary -- + * + * This procedure locates the root that Tcl's library files are mounted + * under if they are under a zipfs file system. + * + * Results: + * TCL_OK if the library was found, TCL_ERROR otherwise. + * + * Side effects: + * Initializes the global variable zipfs_literal_tcl_library. Will + * never be cleared. + * + *------------------------------------------------------------------------- + */ + int TclZipfsLocateTclLibrary(void) { @@ -4314,28 +4337,33 @@ TclZipfsLocateTclLibrary(void) char dllName[(MAX_PATH + LIBRARY_SIZE) * 3]; #endif /* _WIN32 */ - assert(!zipfs_tcl_library_init); + if (zipfs_tcl_library_init) { + 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"; - zipfs_tcl_library_init = 1; - return TCL_OK; + 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(); @@ -4347,38 +4375,26 @@ TclZipfsLocateTclLibrary(void) #endif if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { - zipfs_tcl_library_init = 1; - return TCL_OK; + 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)) { - zipfs_tcl_library_init = 1; - return TCL_OK; + goto unlock_and_return; } #else if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { zipfs_tcl_library_init = 1; - return TCL_OK; + goto unlock_and_return; } #endif /* _WIN32 */ #endif /* !defined(STATIC_BUILD) */ - /* - * If anything set the cache (but subsequently failed) go with that - * anyway. - */ - - if (zipfs_literal_tcl_library) { - return TCL_OK; - } - /* - * No zipfs tcl-library, mark it to avoid performance penalty [62019f8aa9f5ec73], - * by future calls (child interpreters, threads, etc). - */ +unlock_and_return: zipfs_tcl_library_init = 1; - return TCL_ERROR; + Tcl_MutexUnlock(&ZipFSLocateLibMutex); + return zipfs_literal_tcl_library ? TCL_OK : TCL_ERROR; } /* @@ -6506,12 +6522,11 @@ TclZipfs_AppHook( #endif archive = Tcl_GetNameOfExecutable(); TclZipfs_Init(NULL); - /* * Look for init.tcl in one of the locations mounted later in this * function. Errors ignored as other locations may be available. */ - (void) TclZipfsLocateTclLibrary(); + (void)TclZipfsLocateTclLibrary(); if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { int found; -- cgit v0.12 From 0a57b1e0c760a17b280d00ca3dae8d71c0b4bc7f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Aug 2025 15:07:31 +0000 Subject: Delete extraneous redundant line --- generic/tclZipfs.c | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 7d3e6e8..da59cf9 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -4385,7 +4385,6 @@ TclZipfsLocateTclLibrary(void) } #else if (ZipfsAppHookFindTclInit(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { - zipfs_tcl_library_init = 1; goto unlock_and_return; } #endif /* _WIN32 */ -- cgit v0.12 From 7c308a99f761051b2e32d252e5cafe99d7b6fe37 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 3 Aug 2025 17:42:28 +0000 Subject: Re-fix [fccb9f322f]. Also eliminate bumping of file system epoch on every interp creation introduced in Tcl 9 --- generic/tclInterp.c | 1 - generic/tclZipfs.c | 35 ++++++++++++++++++++++++++++++++++- 2 files changed, 34 insertions(+), 2 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 90af06e..b778314 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -466,7 +466,6 @@ Tcl_Init( " }\n" "}\n" "tclInit", TCL_INDEX_NONE, 0); - TclpSetInitialEncodings(); end: *names = (*names)->nextPtr; return result; diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index da59cf9..bb27ae9 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -6489,6 +6489,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 -- @@ -6525,7 +6556,9 @@ TclZipfs_AppHook( * Look for init.tcl in one of the locations mounted later in this * function. Errors ignored as other locations may be available. */ - (void)TclZipfsLocateTclLibrary(); + if (TclZipfsLocateTclLibrary() == TCL_OK) { + (void) TclZipfsInitEncodingDirs(); + } if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { int found; -- cgit v0.12 From 8b2e59a8c83da300f868d1545a89616fbf6e9575 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Aug 2025 09:45:38 +0000 Subject: Tweak test failing on macos to report macos result --- tests/unixInit.test | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) 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 -- cgit v0.12 From eb1fba12e2552be1c75e7c53bf69ff88cbe28b05 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 6 Aug 2025 02:06:11 +0000 Subject: Reintroduce TclpSetInitialEncoding for --disable-zipfs case --- generic/tclInterp.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b778314..90af06e 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -466,6 +466,7 @@ Tcl_Init( " }\n" "}\n" "tclInit", TCL_INDEX_NONE, 0); + TclpSetInitialEncodings(); end: *names = (*names)->nextPtr; return result; -- cgit v0.12 From e1d9fc8bc199e1673586a9a4768a775e5ecf3c64 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 6 Aug 2025 02:17:47 +0000 Subject: Only update file system epoch if system encoding changes --- generic/tclEncoding.c | 33 ++++++++++++++++++++++----------- 1 file changed, 22 insertions(+), 11 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ce5fda4..d3914da 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; -- cgit v0.12