diff options
| -rw-r--r-- | ChangeLog | 73 | ||||
| -rw-r--r-- | generic/tclBasic.c | 4 | ||||
| -rw-r--r-- | generic/tclEncoding.c | 672 | ||||
| -rw-r--r-- | generic/tclEvent.c | 147 | ||||
| -rw-r--r-- | generic/tclIO.c | 5 | ||||
| -rw-r--r-- | generic/tclInt.decls | 11 | ||||
| -rw-r--r-- | generic/tclInt.h | 49 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 34 | ||||
| -rw-r--r-- | generic/tclInterp.c | 277 | ||||
| -rw-r--r-- | generic/tclNotify.c | 25 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 5 | ||||
| -rw-r--r-- | generic/tclTest.c | 6 | ||||
| -rw-r--r-- | generic/tclUtil.c | 330 | ||||
| -rw-r--r-- | tests/encoding.test | 6 | ||||
| -rw-r--r-- | tests/unixInit.test | 109 | ||||
| -rw-r--r-- | unix/tclUnixFile.c | 41 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 523 | ||||
| -rw-r--r-- | unix/tclUnixTest.c | 30 | ||||
| -rw-r--r-- | win/tclWinFile.c | 20 | ||||
| -rw-r--r-- | win/tclWinInit.c | 338 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 8 |
21 files changed, 1556 insertions, 1157 deletions
@@ -1,3 +1,76 @@ +2004-11-30 Don Porter <dgp@users.sourceforge.net> + + Patch 976520 reworks several of the details involved with + startup/initialization of the Tcl library, focused on the + activities of Tcl_FindExecutable(). + + * generic/tclIO.c: Removed bogus claim in comment that + encoding "iso8859-1" is "built-in" to Tcl. + + * generic/tclInt.h: Created a new struct ProcessGlobalValue, + * generic/tclUtil.c: routines Tcl(Get|Set)ProcessGlobalValue, + and function type TclInitProcessGlobalValueProc. Together, these + take care of the housekeeping for "values" (things that can be + held in a Tcl_Obj) that are global across a whole process. That is, + they are shared among multiple threads, and epoch and mutex + protection must govern the validity of cached copies maintained + in each thread. + + * generic/tclNotify.c: Modified TclInitNotifier() to tolerate + being called multiple times in the same thread. + + * generic/tclEvent.c: Dropped the unused argv0 argument to + TclInitSubsystems(). Removed machinery to unsure only one + TclInitNotifier() call per thread, now that that is safe. + Converted Tcl(Get|Set)LibraryPath to use a ProcessGlobalValue, + and moved them to tclEncoding.c. + * generic/tclBasic.c: Updated caller. + + * generic/tclInt.h: TclpFindExecutable now returns void. + * unix/tclUnixFile.c: + * win/tclWinFile.c: + * win/tclWinPipe.c: + + * generic/tclEncoding.c: Built new encoding search initialization + on a foundation of ProcessGlobalValues, exposing new routines + Tcl(Get|Set)EncodingSearchPath. A cache of a map from encoding name + to directory pathname keeps track of where encodings are available + for loading. Tcl_FindExecutable greatly simplified into just + three function calls. The "library path" is now misnamed, as its + only remaining purpose is as a foundation for the default encoding + search path. + + * generic/tclInterp.c: Inlined the initScript that is evaluated + by Tcl_Init(). Added verification after initScript evaluation + that Tcl can find its installed *.enc files, and that it has + initialized [encoding system] in agreement with what the environment + expects. [tclInit] no longer driven by the value of $::tcl_libPath; + it largely constructs its own search path now, rather than attempt + to share one with the encoding system. + + * unix/tclUnixInit.c: TclpSetInitialEncodings factored so that a new + * win/tclWinInit.c: routine TclpGetEncodingNameFromEnvironment + can reveal that Tcl thinks the [encoding system] should be, even + when an incomplete encoding search path, or a missing *.enc file + won't allow that initialization to succeed. TclpInitLibraryPath + reworked as an initializer of a ProcessGlobalValue. + + * unix/tclUnixTest.c: Update implementations of [testfindexecutable], + [testgetdefenc], and [testsetdefenc]. + + * tests/unixInit.test: Corrected tests to operate properly even + when a value of TCL_LIBRARY is required to find encodings. + + * generic/tclInt.decls: New internal stubs: TclGetEncodingSearchPath, + TclSetEncodingSearchPath, TclpGetEncodingNameFromEnvironment. These + are candidates for public exposure by future TIPs. + + * generic/tclIntDecls.h: make genstubs + * generic/tclStubInit.c: + + * generic/tclTest.c: Updated [testencoding] to use + * tests/encoding.test: Tcl(Get|Set)EncodingSearchPath. Updated tests. + 2004-11-30 Kevin B. Kenny <kennykb@acm.org> * library/clock.tcl: Corrected the regular expressions that match diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a37dff5..d4c9382 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.135 2004/11/13 00:19:06 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.136 2004/11/30 19:34:46 dgp Exp $ */ #include "tclInt.h" @@ -183,7 +183,7 @@ Tcl_CreateInterp() ByteCodeStats *statsPtr; #endif /* TCL_COMPILE_STATS */ - TclInitSubsystems(NULL); + TclInitSubsystems(); /* * Panic if someone updated the CallFrame structure without diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index b24bb0e..c3f53c3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.26 2004/11/12 23:42:17 hobbs Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.27 2004/11/30 19:34:47 dgp Exp $ */ #include "tclInt.h" @@ -135,12 +135,35 @@ typedef struct EscapeEncodingData { #define ENCODING_ESCAPE 3 /* - * Initialize the default encoding directory. If this variable contains - * a non NULL value, it will be the first path used to locate the - * system encoding files. + * A list of directories in which Tcl should look for *.enc files. + * This list is shared by all threads. Access is governed by a + * mutex lock. */ -char *tclDefaultEncodingDir = NULL; +static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; +static ProcessGlobalValue encodingSearchPath = + {0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL}; + +/* + * A map from encoding names to the directories in which their data + * files have been seen. The string value of the map is shared by all + * threads. Access to the shared string is governed by a mutex lock. + */ + +static TclInitProcessGlobalValueProc InitializeEncodingFileMap; +static ProcessGlobalValue encodingFileMap = + {0, 0, NULL, NULL, InitializeEncodingFileMap, NULL, NULL}; + +/* + * A list of directories making up the "library path". Historically + * this search path has served many uses, but the only one remaining + * is a base for the encodingSearchPath above. If the application + * does not explicitly set the encodingSearchPath, then it will be + * initialized by appending /encoding to each directory in this + * "libraryPath". + */ +static ProcessGlobalValue libraryPath = + {0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL}; static int encodingsInitialized = 0; @@ -188,6 +211,7 @@ static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); +static void FillEncodingFileMap (); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); @@ -197,8 +221,7 @@ static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name, int type, Tcl_Channel chan)); static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, Tcl_Channel chan)); -static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir, - CONST char *name)); +static Tcl_Obj * MakeFileMap (); static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, @@ -236,10 +259,198 @@ static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); -static int FindEncodings(); /* + *---------------------------------------------------------------------- + * + * TclGetEncodingSearchPath -- + * + * Keeps the per-thread copy of the encoding search path current + * with changes to the global copy. + * + * Results: + * Returns a "list" (Tcl_Obj *) that contains the encoding + * search path. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetEncodingSearchPath() { + return TclGetProcessGlobalValue(&encodingSearchPath); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetEncodingSearchPath -- + * + * Keeps the per-thread copy of the encoding search path current + * with changes to the global copy. + * + *---------------------------------------------------------------------- + */ + +int +TclSetEncodingSearchPath(searchPath) + Tcl_Obj *searchPath; +{ + int dummy; + + if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) { + return TCL_ERROR; + } + TclSetProcessGlobalValue(&encodingSearchPath, searchPath); + FillEncodingFileMap(); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetLibraryPath -- + * + * Keeps the per-thread copy of the library path current + * with changes to the global copy. + * + * Results: + * Returns a "list" (Tcl_Obj *) that contains the library path. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetLibraryPath() { + return TclGetProcessGlobalValue(&libraryPath); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetLibraryPath -- + * + * Keeps the per-thread copy of the library path current + * with changes to the global copy. + * + * NOTE: this routine returns void, so there's no way to + * report the error that searchPath is not a valid list. + * In that case, this routine will silently do nothing. + * + *---------------------------------------------------------------------- + */ + +void +TclSetLibraryPath(path) + Tcl_Obj *path; +{ + int dummy; + + if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) { + return; + } + TclSetProcessGlobalValue(&libraryPath, path); +} + +/* + *--------------------------------------------------------------------------- + * + * MakeFileMap -- + * + * Scan the directories on the encoding search path, find the + * *.enc files, and store the found pathnames in a map associated + * with the encoding name. + * + * In particular, if $dir is on the encoding search path, and the + * file $dir/foo.enc is found, then store a "foo" -> $dir entry + * in the map. Later, any need for the "foo" encoding will quickly + * be able to construct the $dir/foo.enc pathname for reading the + * encoding data. + * + * Results: + * None. + * + * Side effects: + * Entries are added to the encoding file map. + * + *--------------------------------------------------------------------------- + */ + +static Tcl_Obj * +MakeFileMap() +{ + int i, numDirs = 0; + Tcl_Obj *map, *searchPath; + + searchPath = TclGetEncodingSearchPath(); + Tcl_IncrRefCount(searchPath); + Tcl_ListObjLength(NULL, searchPath, &numDirs); + map = Tcl_NewDictObj(); + Tcl_IncrRefCount(map); + for (i = numDirs-1; i >= 0; i--) { + /* + * Iterate backwards through the search path so as we + * overwrite entries found, we favor files earlier on + * the search path. + */ + int j, numFiles; + Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); + Tcl_Obj **filev; + Tcl_GlobTypeData readableFiles = + {TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL}; + + Tcl_ListObjIndex(NULL, searchPath, i, &directory); + Tcl_IncrRefCount(directory); + Tcl_IncrRefCount(matchFileList); + Tcl_FSMatchInDirectory(NULL, matchFileList, + directory, "*.enc", &readableFiles); + + Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); + for (j=0; j<numFiles; j++) { + Tcl_Obj *encodingName, *file; + + file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL); + Tcl_IncrRefCount(file); + encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT); + Tcl_IncrRefCount(encodingName); + Tcl_DictObjPut(NULL, map, encodingName, directory); + } + Tcl_DecrRefCount(matchFileList); + Tcl_DecrRefCount(directory); + } + Tcl_DecrRefCount(searchPath); + return map; +} + +/* + *--------------------------------------------------------------------------- + * + * FillEncodingFileMap -- + * + * Called to bring the encoding file map in sync with the current + * value of the encoding search path. + * + * TODO: Check the callers of this routine to see if it's called + * too frequently. + * + * Results: + * None. + * + * Side effects: + * Entries are added to the encoding file map. + * + *--------------------------------------------------------------------------- + */ + +void +FillEncodingFileMap() +{ + Tcl_Obj *map = MakeFileMap(); + TclSetProcessGlobalValue(&encodingFileMap, map); + Tcl_DecrRefCount(map); +} + +/* *--------------------------------------------------------------------------- * * TclInitEncodingSubsystem -- @@ -261,6 +472,10 @@ TclInitEncodingSubsystem() { Tcl_EncodingType type; + if (encodingsInitialized) { + return; + } + Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); @@ -296,8 +511,10 @@ TclInitEncodingSubsystem() type.nullSize = 2; type.clientData = NULL; Tcl_CreateEncoding(&type); -} + encodingsInitialized = 1; + +} /* *---------------------------------------------------------------------- @@ -344,10 +561,15 @@ TclFinalizeEncodingSubsystem() * * Tcl_GetDefaultEncodingDir -- * + * Legacy public interface to retrieve first directory in the + * encoding searchPath. * * Results: + * The directory pathname, as a string, or NULL for an empty + * encoding search path. * * Side effects: + * None. * *------------------------------------------------------------------------- */ @@ -355,7 +577,16 @@ TclFinalizeEncodingSubsystem() CONST char * Tcl_GetDefaultEncodingDir() { - return tclDefaultEncodingDir; + int numDirs; + Tcl_Obj *first, *searchPath = TclGetEncodingSearchPath(); + + Tcl_ListObjLength(NULL, searchPath, &numDirs); + if (numDirs == 0) { + return NULL; + } + Tcl_ListObjIndex(NULL, searchPath, 0, &first); + + return Tcl_GetString(first); } /* @@ -363,10 +594,14 @@ Tcl_GetDefaultEncodingDir() * * Tcl_SetDefaultEncodingDir -- * + * Legacy public interface to set the first directory in the + * encoding search path. * * Results: + * None. * * Side effects: + * Modifies the encoding search path. * *------------------------------------------------------------------------- */ @@ -375,8 +610,12 @@ void Tcl_SetDefaultEncodingDir(path) CONST char *path; { - tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1); - strcpy(tclDefaultEncodingDir, path); + Tcl_Obj *searchPath = TclGetEncodingSearchPath(); + Tcl_Obj *directory = Tcl_NewStringObj(path, -1); + + searchPath = Tcl_DuplicateObj(searchPath); + Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); + TclSetEncodingSearchPath(searchPath); } /* @@ -551,95 +790,42 @@ void Tcl_GetEncodingNames(interp) Tcl_Interp *interp; /* Interp to hold result. */ { + Tcl_HashTable table; Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Tcl_Obj *pathPtr, *resultPtr; - int dummy; + Tcl_Obj *map, *name, *result = Tcl_NewObj(); + Tcl_DictSearch mapSearch; + int dummy, done = 0; - Tcl_HashTable table; + Tcl_InitObjHashTable(&table); + /* Copy encoding names from loaded encoding table to table */ Tcl_MutexLock(&encodingMutex); - Tcl_InitHashTable(&table, TCL_STRING_KEYS); - hPtr = Tcl_FirstHashEntry(&encodingTable, &search); - while (hPtr != NULL) { - Encoding *encodingPtr; - - encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); - Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy); - hPtr = Tcl_NextHashEntry(&search); + for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); + Tcl_CreateHashEntry(&table, + (char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy); } Tcl_MutexUnlock(&encodingMutex); - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int i, objc; - Tcl_Obj **objv; - char globArgString[10]; - Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1); - Tcl_IncrRefCount(encodingObj); - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); + FillEncodingFileMap(); + map = TclGetProcessGlobalValue(&encodingFileMap); - for (i = 0; i < objc; i++) { - Tcl_Obj *searchIn; - - /* - * Construct the path from the element of pathPtr, - * joined with 'encoding'. - */ - searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj); - Tcl_IncrRefCount(searchIn); - Tcl_ResetResult(interp); - - /* - * TclGlob() changes the contents of globArgString, which causes - * a segfault if we pass in a pointer to non-writeable memory. - * TclGlob() puts its results directly into interp. - */ - - strcpy(globArgString, "*.enc"); - /* - * The GLOBMODE_TAILS flag returns just the tail of each file - * which is the encoding name with a .enc extension - */ - if ((TclGlob(interp, globArgString, searchIn, - TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) { - int objc2 = 0; - Tcl_Obj **objv2; - int j; - - Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2, - &objv2); - - for (j = 0; j < objc2; j++) { - int length; - char *string; - string = Tcl_GetStringFromObj(objv2[j], &length); - length -= 4; - if (length > 0) { - string[length] = '\0'; - Tcl_CreateHashEntry(&table, string, &dummy); - string[length] = '.'; - } - } - } - Tcl_DecrRefCount(searchIn); - } - Tcl_DecrRefCount(encodingObj); + /* Copy encoding names from encoding file map to table */ + Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); + for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { + Tcl_CreateHashEntry(&table, (char *) name, &dummy); } - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&table, &search); - while (hPtr != NULL) { - Tcl_Obj *strPtr; - - strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1); - Tcl_ListObjAppendElement(NULL, resultPtr, strPtr); - hPtr = Tcl_NextHashEntry(&search); + /* Pull all encoding names from table into the result list */ + for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_ListObjAppendElement(NULL, result, + (Tcl_Obj *) Tcl_GetHashKey(&table, hPtr)); } + Tcl_SetObjResult(interp, result); Tcl_DeleteHashTable(&table); - Tcl_SetObjResult(interp, resultPtr); } /* @@ -1105,9 +1291,9 @@ Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, * None. * * Side effects: - * The variable tclExecutableName gets filled in with the file + * The variable tclNativeExecutableName gets filled in with the file * name for the application, if we figured it out. If we couldn't - * figure it out, tclExecutableName is set to NULL. + * figure it out, tclNativeExecutableName is set to NULL. * *--------------------------------------------------------------------------- */ @@ -1117,59 +1303,9 @@ Tcl_FindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ { - int mustCleanUtf; - CONST char *name; - Tcl_DString buffer, nameString; - - TclInitSubsystems(argv0); - - if (argv0 == NULL) { - goto done; - } - if (tclExecutableName != NULL) { - ckfree(tclExecutableName); - tclExecutableName = NULL; - } - if ((name = TclpFindExecutable(argv0)) == NULL) { - goto done; - } - - /* - * The value returned from TclpNameOfExecutable is a UTF string that - * is possibly dirty depending on when it was initialized. - * FindEncodings will indicate whether we must "clean" the UTF (as - * reported by the underlying system). To assure that the UTF string - * is a properly encoded native string for this system, convert the - * UTF string to the default native encoding before the default - * encoding is initialized. Then, convert it back to UTF after the - * system encoding is loaded. - */ - - Tcl_UtfToExternalDString(NULL, name, -1, &buffer); - mustCleanUtf = FindEncodings(); - - /* - * Now it is OK to convert the native string back to UTF and set - * the value of the tclExecutableName. - */ - - if (mustCleanUtf) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1, - &nameString); - tclExecutableName = (char *) - ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); - strcpy(tclExecutableName, Tcl_DStringValue(&nameString)); - - Tcl_DStringFree(&nameString); - } else { - tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1)); - strcpy(tclExecutableName, name); - } - Tcl_DStringFree(&buffer); - return; - - done: - (void) FindEncodings(); + TclInitSubsystems(); + TclpSetInitialEncodings(); + TclpFindExecutable(argv0); } /* @@ -1198,28 +1334,42 @@ LoadEncodingFile(interp, name) CONST char *name; /* The name of the encoding file on disk * and also the name for new encoding. */ { - int objc, i, ch; - Tcl_Obj **objv; - Tcl_Obj *pathPtr; Tcl_Channel chan; Tcl_Encoding encoding; + Tcl_Obj *map, *path, *directory = NULL; + Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); + int ch, scanned = 0; - pathPtr = TclGetLibraryPath(); - if (pathPtr == NULL) { - goto unknown; - } - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - chan = NULL; - for (i = 0; i < objc; i++) { - chan = OpenEncodingFile(Tcl_GetString(objv[i]), name); - if (chan != NULL) { + Tcl_IncrRefCount(nameObj); + while (1) { + map = TclGetProcessGlobalValue(&encodingFileMap); + Tcl_DictObjGet(NULL, map, nameObj, &directory); + if (scanned || (NULL != directory)) { break; } +scan: + FillEncodingFileMap(); + scanned = 1; + } + if (NULL == directory) { + Tcl_DecrRefCount(nameObj); + goto unknown; } - if (chan == NULL) { + /* Construct $directory/$encoding.enc path name */ + Tcl_IncrRefCount(directory); + Tcl_AppendToObj(nameObj, ".enc", -1); + path = Tcl_FSJoinToPath(directory, 1, &nameObj); + Tcl_DecrRefCount(directory); + Tcl_IncrRefCount(path); + chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0); + Tcl_DecrRefCount(path); + + if (NULL == chan) { + if (!scanned) { + goto scan; + } goto unknown; } @@ -1270,53 +1420,6 @@ LoadEncodingFile(interp, name) } /* - *---------------------------------------------------------------------- - * - * OpenEncodingFile -- - * - * Look for the file encoding/<name>.enc in the specified - * directory. - * - * Results: - * Returns an open file channel if the file exists. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Channel -OpenEncodingFile(dir, name) - CONST char *dir; - CONST char *name; - -{ - CONST char *argv[3]; - Tcl_DString pathString; - CONST char *path; - Tcl_Channel chan; - Tcl_Obj *pathPtr; - - argv[0] = dir; - argv[1] = "encoding"; - argv[2] = name; - - Tcl_DStringInit(&pathString); - Tcl_JoinPath(3, argv, &pathString); - path = Tcl_DStringAppend(&pathString, ".enc", -1); - pathPtr = Tcl_NewStringObj(path,-1); - - Tcl_IncrRefCount(pathPtr); - chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0); - Tcl_DecrRefCount(pathPtr); - - Tcl_DStringFree(&pathString); - - return chan; -} - -/* *------------------------------------------------------------------------- * * LoadTableEncoding -- @@ -2932,91 +3035,108 @@ unilen(src) } return (char *) p - src; } - /* *------------------------------------------------------------------------- * - * FindEncodings -- + * InitializeEncodingSearchPath -- * - * Find and load the encoding file for this operating system. - * Before this is called, Tcl makes assumptions about the - * native string representation, but the true encoding is not - * assured. + * This is the fallback routine that sets the default value + * of the encoding search path if the application has not set + * one via a call to TclSetEncodingSearchPath() by the first + * time the search path is needed to load encoding data. + * + * The default encoding search path is produced by taking each + * directory in the library path, appending a subdirectory + * named "encoding", and if the resulting directory exists, + * adding it to the encoding search path. * * Results: - * Return result of TclpInitLibraryPath, which reports whether the - * path is clean (0) or dirty (1) UTF. + * None. * * Side effects: - * Varied, see the respective initialization routines. + * Sets the encoding search path to an initial value. * *------------------------------------------------------------------------- */ -static int -FindEncodings() +void +InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; { - int mustCleanUtf = 0; - - if (encodingsInitialized == 0) { - /* - * Double check inside the mutex. There may be calls - * back into this routine from some of the procedures below. - */ - - TclpInitLock(); - if (encodingsInitialized == 0) { - Tcl_Obj *pathPtr; - Tcl_DString libPath, buffer; - - /* - * Have to set this bit here to avoid deadlock with the - * routines below us that call into TclInitSubsystems. - */ - - encodingsInitialized = 1; - - /* - * NOTE: we can safely make direct use of tclNativeExecutableName - * because we know all our callers ( Tcl_FindExecutable() is the - * only one) have already called TclpFindExecutable(). - */ - - mustCleanUtf = TclpInitLibraryPath(tclNativeExecutableName); - - /* - * The library path was set in the TclpInitLibraryPath routine. - * The string set is a dirty UTF string. To preserve the value - * convert the UTF string back to native before setting the new - * default encoding. - */ - - pathPtr = TclGetLibraryPath(); - if ((pathPtr != NULL) && mustCleanUtf) { - Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1, - &libPath); - } - - TclpSetInitialEncodings(); - - /* - * Now convert the native string back to UTF. - */ - - if ((pathPtr != NULL) && mustCleanUtf) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1, - &buffer); - pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1); - TclSetLibraryPath(pathPtr); - - Tcl_DStringFree(&libPath); - Tcl_DStringFree(&buffer); - } + char *bytes; + int i, numDirs, numBytes; + Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1); + Tcl_Obj *searchPath = Tcl_NewObj(); + + Tcl_IncrRefCount(encodingObj); + Tcl_IncrRefCount(searchPath); + libPath = TclGetLibraryPath(); + Tcl_IncrRefCount(libPath); + Tcl_ListObjLength(NULL, libPath, &numDirs); + for (i = 0; i < numDirs; i++) { + Tcl_Obj *directory, *path; + Tcl_StatBuf stat; + + Tcl_ListObjIndex(NULL, libPath, i, &directory); + path = Tcl_FSJoinToPath(directory, 1, &encodingObj); + Tcl_IncrRefCount(path); + if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) { + Tcl_ListObjAppendElement(NULL, searchPath, path); } - TclpInitUnlock(); - } - - return mustCleanUtf; + Tcl_IncrRefCount(path); + } + Tcl_DecrRefCount(libPath); + Tcl_DecrRefCount(encodingObj); + *encodingPtr = libraryPath.encoding; + if (*encodingPtr) { + ((Encoding *)(*encodingPtr))->refCount++; + } + bytes = Tcl_GetStringFromObj(searchPath, &numBytes); + *lengthPtr = numBytes; + *valuePtr = ckalloc((unsigned int) numBytes + 1); + memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); + Tcl_DecrRefCount(searchPath); +} + +/* + *------------------------------------------------------------------------- + * + * InitializeEncodingFileMap -- + * + * This is the fallback routine that fills the encoding data + * file map if the application has not set up an encoding + * search path by the first time the file map is needed to + * load encoding data. + * + * Results: + * None. + * + * Side effects: + * Fills the encoding data file map. + * + *------------------------------------------------------------------------- + */ + +void +InitializeEncodingFileMap(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; +{ + char *bytes; + int numBytes; + Tcl_Obj *map = MakeFileMap(); + + *encodingPtr = encodingSearchPath.encoding; + if (*encodingPtr) { + ((Encoding *)(*encodingPtr))->refCount++; + } + bytes = Tcl_GetStringFromObj(map, &numBytes); + *lengthPtr = numBytes; + *valuePtr = ckalloc((unsigned int) numBytes + 1); + memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); + Tcl_DecrRefCount(map); } - diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 57ec9b7..f180f26 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.52 2004/11/18 20:15:32 dgp Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.53 2004/11/30 19:34:47 dgp Exp $ */ #include "tclInt.h" @@ -98,17 +98,9 @@ typedef struct ThreadSpecificData { int inExit; /* True when this thread is exiting. This * is used as a hack to decide to close * the standard channels. */ - Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -/* - * Common string for the library path for sharing across threads. - * This is ckalloc'd and cleared in Tcl_Finalize. - */ -static char *tclLibraryPathStr = NULL; - - #ifdef TCL_THREADS typedef struct { @@ -747,92 +739,6 @@ Tcl_Exit(status) /* *------------------------------------------------------------------------- - * - * TclSetLibraryPath -- - * - * Set the path that will be used for searching for init.tcl and - * encodings when an interp is being created. - * - * Results: - * None. - * - * Side effects: - * Changing the library path will affect what directories are - * examined when looking for encodings for all interps from that - * point forward. - * - * The refcount of the new library path is incremented and the - * refcount of the old path is decremented. - * - *------------------------------------------------------------------------- - */ - -void -TclSetLibraryPath(pathPtr) - Tcl_Obj *pathPtr; /* A Tcl list object whose elements are - * the new library path. */ -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - const char *toDupe; - int size; - - if (pathPtr != NULL) { - Tcl_IncrRefCount(pathPtr); - } - if (tsdPtr->tclLibraryPath != NULL) { - Tcl_DecrRefCount(tsdPtr->tclLibraryPath); - } - tsdPtr->tclLibraryPath = pathPtr; - - /* - * No mutex locking is needed here as up the stack we're within - * TclpInitLock(). - */ - if (tclLibraryPathStr != NULL) { - ckfree(tclLibraryPathStr); - } - toDupe = Tcl_GetStringFromObj(pathPtr, &size); - tclLibraryPathStr = ckalloc((unsigned)size+1); - memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1); -} - -/* - *------------------------------------------------------------------------- - * - * TclGetLibraryPath -- - * - * Return a Tcl list object whose elements are the library path. - * The caller should not modify the contents of the returned object. - * - * Results: - * As above. - * - * Side effects: - * None. - * - *------------------------------------------------------------------------- - */ - -Tcl_Obj * -TclGetLibraryPath() -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (tsdPtr->tclLibraryPath == NULL) { - /* - * Grab the shared string and place it into a new thread specific - * Tcl_Obj. - */ - tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1); - - /* take ownership */ - Tcl_IncrRefCount(tsdPtr->tclLibraryPath); - } - return tsdPtr->tclLibraryPath; -} - -/* - *------------------------------------------------------------------------- * * TclInitSubsystems -- * @@ -858,25 +764,12 @@ TclGetLibraryPath() */ void -TclInitSubsystems(argv0) - CONST char *argv0; /* Name of executable from argv[0] to main() - * in native multi-byte encoding. */ +TclInitSubsystems() { - ThreadSpecificData *tsdPtr; - if (inFinalize != 0) { Tcl_Panic("TclInitSubsystems called while finalizing"); } - /* - * Grab the thread local storage pointer before doing anything because - * the initialization routines will be registering exit handlers. - * We use this pointer to detect if this is the first time this - * thread has created an interpreter. - */ - - tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); - if (subsystemsInitialized == 0) { /* * Double check inside the mutex. There are definitly calls @@ -892,8 +785,6 @@ TclInitSubsystems(argv0) subsystemsInitialized = 1; - tclExecutableName = NULL; - /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the @@ -914,17 +805,7 @@ TclInitSubsystems(argv0) } TclpInitUnlock(); } - - if (tsdPtr == NULL) { - /* - * First time this thread has created an interpreter. - * We fetch the key again just in case no exit handlers were - * registered by this point. - */ - - (void) TCL_TSD_INIT(&dataKey); - TclInitNotifier(); - } + TclInitNotifier(); } /* @@ -1017,22 +898,10 @@ Tcl_Finalize() */ TclFinalizeEncodingSubsystem(); - if (tclExecutableName != NULL) { - ckfree(tclExecutableName); - tclExecutableName = NULL; - } if (tclNativeExecutableName != NULL) { ckfree(tclNativeExecutableName); tclNativeExecutableName = NULL; } - if (tclDefaultEncodingDir != NULL) { - ckfree(tclDefaultEncodingDir); - tclDefaultEncodingDir = NULL; - } - if (tclLibraryPathStr != NULL) { - ckfree(tclLibraryPathStr); - tclLibraryPathStr = NULL; - } Tcl_SetPanicProc(NULL); @@ -1113,16 +982,6 @@ Tcl_FinalizeThread() if (tsdPtr != NULL) { tsdPtr->inExit = 1; - /* - * Clean up the library path now, before we invalidate thread-local - * storage or calling thread exit handlers. - */ - - if (tsdPtr->tclLibraryPath != NULL) { - Tcl_DecrRefCount(tsdPtr->tclLibraryPath); - tsdPtr->tclLibraryPath = NULL; - } - for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL; exitPtr = tsdPtr->firstExitPtr) { /* diff --git a/generic/tclIO.c b/generic/tclIO.c index b41a7b6..bb6c438 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.80 2004/11/09 15:47:26 dkf Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.81 2004/11/30 19:34:47 dgp Exp $ */ #include "tclInt.h" @@ -3556,8 +3556,7 @@ Tcl_GetsObj(chan, objPtr) /* * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't - * produce ByteArray objects. To avoid circularity problems, - * "iso8859-1" is builtin to Tcl. + * produce ByteArray objects. */ if (encoding == NULL) { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 3b5dc5d..d6cdd1f 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.82 2004/10/27 17:13:58 davygrvy Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.83 2004/11/30 19:34:48 dgp Exp $ library tcl @@ -841,6 +841,15 @@ declare 208 generic { Tcl_Channel TclpOpenFileChannel (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions) } +declare 209 generic { + Tcl_Obj * TclGetEncodingSearchPath(void) +} +declare 210 generic { + int TclSetEncodingSearchPath(Tcl_Obj *searchPath) +} +declare 211 generic { + CONST char * TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr) +} ############################################################################## diff --git a/generic/tclInt.h b/generic/tclInt.h index a4ac12e..4510239 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.200 2004/11/17 17:53:01 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.201 2004/11/30 19:34:48 dgp Exp $ */ #ifndef _TCLINT @@ -1688,14 +1688,46 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; /* *---------------------------------------------------------------- + * Data structures for process-global values. + *---------------------------------------------------------------- + */ + +typedef void (TclInitProcessGlobalValueProc) _ANSI_ARGS_((char **valuePtr, + int *lengthPtr, Tcl_Encoding *encodingPtr)); + +/* + * A ProcessGlobalValue struct exists for each internal value in + * Tcl that is to be shared among several threads. Each thread + * sees a (Tcl_Obj) copy of the value, and the master is kept as + * a counted string, with epoch and mutex control. Each ProcessGlobalValue + * struct should be a static variable in some file. + */ +typedef struct ProcessGlobalValue { + int epoch; /* Epoch counter to detect changes + * in the master value */ + int numBytes; /* Length of the master string */ + char *value; /* The master string value */ + Tcl_Encoding encoding; /* system encoding when master string + * was initialized */ + TclInitProcessGlobalValueProc *proc; + /* A procedure to initialize the + * master string copy when a "get" + * request comes in before any + * "set" request has been received. */ + Tcl_Mutex mutex; /* Enforce orderly access from + * multiple threads */ + Tcl_ThreadDataKey key; /* Key for per-thread data holding + * the (Tcl_Obj) copy for each thread */ +} ProcessGlobalValue; + +/* + *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- */ -MODULE_SCOPE char * tclExecutableName; MODULE_SCOPE char * tclNativeExecutableName; MODULE_SCOPE int tclFindExecutableSearchDone; -MODULE_SCOPE char * tclDefaultEncodingDir; MODULE_SCOPE char * tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier; @@ -1802,6 +1834,8 @@ MODULE_SCOPE void TclFinalizeSynchronization _ANSI_ARGS_((void)); MODULE_SCOPE void TclFinalizeLock _ANSI_ARGS_((void)); MODULE_SCOPE void TclFinalizeThreadData _ANSI_ARGS_((void)); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp)); +MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue _ANSI_ARGS_ (( + ProcessGlobalValue *pgvPtr)); MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types)); @@ -1815,7 +1849,7 @@ MODULE_SCOPE void TclInitLimitSupport _ANSI_ARGS_((Tcl_Interp *interp)); MODULE_SCOPE void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitNotifier _ANSI_ARGS_((void)); MODULE_SCOPE void TclInitObjSubsystem _ANSI_ARGS_((void)); -MODULE_SCOPE void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); +MODULE_SCOPE void TclInitSubsystems (); MODULE_SCOPE int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, int len)); MODULE_SCOPE int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, @@ -1879,11 +1913,12 @@ MODULE_SCOPE int TclpThreadCreate _ANSI_ARGS_(( int stackSize, int flags)); MODULE_SCOPE void TclpFinalizeThreadDataKey _ANSI_ARGS_(( Tcl_ThreadDataKey *keyPtr)); -MODULE_SCOPE char * TclpFindExecutable _ANSI_ARGS_(( +MODULE_SCOPE void TclpFindExecutable _ANSI_ARGS_(( CONST char *argv0)); MODULE_SCOPE int TclpFindVariable _ANSI_ARGS_((CONST char *name, int *lengthPtr)); -MODULE_SCOPE int TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0)); +MODULE_SCOPE void TclpInitLibraryPath _ANSI_ARGS_((char **valuePtr, + int *lengthPtr, Tcl_Encoding *encodingPtr)); MODULE_SCOPE void TclpInitLock _ANSI_ARGS_((void)); MODULE_SCOPE void TclpInitPlatform _ANSI_ARGS_((void)); MODULE_SCOPE void TclpInitUnlock _ANSI_ARGS_((void)); @@ -1951,6 +1986,8 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks _ANSI_ARGS_(( Tcl_Interp *interp)); MODULE_SCOPE void TclSetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *cmdPrefix)); +MODULE_SCOPE void TclSetProcessGlobalValue _ANSI_ARGS_ (( + ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue)); MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, int result)); MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index eba2fa4..69ddc6a 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIntDecls.h,v 1.73 2004/11/03 19:13:38 davygrvy Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.74 2004/11/30 19:34:49 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -1085,6 +1085,23 @@ EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj * pathPtr, EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); #endif +#ifndef TclGetEncodingSearchPath_TCL_DECLARED +#define TclGetEncodingSearchPath_TCL_DECLARED +/* 209 */ +EXTERN Tcl_Obj * TclGetEncodingSearchPath _ANSI_ARGS_((void)); +#endif +#ifndef TclSetEncodingSearchPath_TCL_DECLARED +#define TclSetEncodingSearchPath_TCL_DECLARED +/* 210 */ +EXTERN int TclSetEncodingSearchPath _ANSI_ARGS_(( + Tcl_Obj * searchPath)); +#endif +#ifndef TclpGetEncodingNameFromEnvironment_TCL_DECLARED +#define TclpGetEncodingNameFromEnvironment_TCL_DECLARED +/* 211 */ +EXTERN CONST char * TclpGetEncodingNameFromEnvironment _ANSI_ARGS_(( + Tcl_DString * bufPtr)); +#endif typedef struct TclIntStubs { int magic; @@ -1314,6 +1331,9 @@ typedef struct TclIntStubs { int (*tclpObjStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 206 */ int (*tclpObjAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 207 */ Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); /* 208 */ + Tcl_Obj * (*tclGetEncodingSearchPath) _ANSI_ARGS_((void)); /* 209 */ + int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */ + CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */ } TclIntStubs; #ifdef __cplusplus @@ -2037,6 +2057,18 @@ extern TclIntStubs *tclIntStubsPtr; #define TclpOpenFileChannel \ (tclIntStubsPtr->tclpOpenFileChannel) /* 208 */ #endif +#ifndef TclGetEncodingSearchPath +#define TclGetEncodingSearchPath \ + (tclIntStubsPtr->tclGetEncodingSearchPath) /* 209 */ +#endif +#ifndef TclSetEncodingSearchPath +#define TclSetEncodingSearchPath \ + (tclIntStubsPtr->tclSetEncodingSearchPath) /* 210 */ +#endif +#ifndef TclpGetEncodingNameFromEnvironment +#define TclpGetEncodingNameFromEnvironment \ + (tclIntStubsPtr->tclpGetEncodingNameFromEnvironment) /* 211 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 194944b..d1cd7f5 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -10,116 +10,13 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.52 2004/11/22 21:24:30 dgp Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.53 2004/11/30 19:34:49 dgp Exp $ */ #include "tclInt.h" #include <stdio.h> /* - * In order to find init.tcl during initialization, the following script - * is invoked by Tcl_Init(). It looks in several different directories: - * - * $tcl_library - can specify a primary location, if set, - * no other locations will be checked. This - * is the recommended way for a program that - * embeds Tcl to specifically tell Tcl where - * to find an init.tcl file. - * - * $env(TCL_LIBRARY) - highest priority so user can always override - * the search path unless the application has - * specified an exact directory above - * - * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl - * on those platforms where it can determine - * at runtime the directory where it expects - * the init.tcl file to be. After [tclInit] - * reads and uses this value, it [unset]s it. - * External users of Tcl should not make use - * of the variable to customize [tclInit]. - * - * $tcl_libPath - OBSOLETE: This variable is no longer - * set by Tcl itself, but [tclInit] examines - * it in case some program that embeds Tcl - * is customizing [tclInit] by setting this - * variable to a list of directories in which - * to search. - * - * [tcl::pkgconfig get scriptdir,runtime] - * - the directory determined by configure to - * be the place where Tcl's script library - * is to be installed. - * - * The first directory on this path that contains a valid init.tcl script - * will be set as the value of tcl_library. - * - * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). - */ - -static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\ - proc tclInit {} {\n\ - global tcl_libPath tcl_library\n\ - global env tclDefaultLibrary\n\ - variable ::tcl::LibPath\n\ - rename tclInit {}\n\ - set errors {}\n\ - set LibPath {}\n\ - if {[info exists tcl_library]} {\n\ - lappend LibPath $tcl_library\n\ - } else {\n\ - if {[info exists env(TCL_LIBRARY)]} {\n\ - lappend LibPath $env(TCL_LIBRARY)\n\ - if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n\ - if {$tail ne [info tclversion]} {\n\ - lappend LibPath [file join [file dirname\\\n\ - $env(TCL_LIBRARY)] tcl[info tclversion]]\n\ - }\n\ - }\n\ - }\n\ - if {[catch {\n\ - lappend LibPath $tclDefaultLibrary\n\ - unset tclDefaultLibrary\n\ - }]} {\n\ - lappend LibPath [::tcl::pkgconfig get scriptdir,runtime]\n\ - }\n\ - set parentDir [file normalize [file dirname [file dirname\\\n\ - [info nameofexecutable]]]]\n\ - set grandParentDir [file dirname $parentDir]\n\ - lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n\ - lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n\ - lappend LibPath [file join $parentDir library]\n\ - lappend LibPath [file join $grandParentDir library]\n\ - lappend LibPath [file join $grandParentDir\\\n\ - tcl[info patchlevel] library]\n\ - lappend LibPath [file join [file dirname $grandParentDir]\\\n\ - tcl[info patchlevel] library]\n\ - catch {\n\ - set LibPath [concat $LibPath $tcl_libPath]\n\ - }\n\ - }\n\ - foreach i $LibPath {\n\ - set tcl_library $i\n\ - set tclfile [file join $i init.tcl]\n\ - if {[file exists $tclfile]} {\n\ - if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n\ - return\n\ - } else {\n\ - append errors \"$tclfile: $msg\n\"\n\ - append errors \"[dict get $opts -errorinfo]\n\"\n\ - }\n\ - }\n\ - }\n\ - set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\ - append msg \" $LibPath\n\n\"\n\ - append msg \"$errors\n\n\"\n\ - append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\ - error $msg\n\ - }\n\ -}\n\ -tclInit"; - -/* * A pointer to a string that holds an initialization script that if non-NULL * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the procedure below. @@ -404,12 +301,182 @@ int Tcl_Init(interp) Tcl_Interp *interp; /* Interpreter to initialize. */ { + int code; + Tcl_DString script, encodingName; + Tcl_Obj *path; + if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); }; } - return Tcl_Eval(interp, initScript); +/* + * In order to find init.tcl during initialization, the following script + * is invoked by Tcl_Init(). It looks in several different directories: + * + * $tcl_library - can specify a primary location, if set, + * no other locations will be checked. This + * is the recommended way for a program that + * embeds Tcl to specifically tell Tcl where + * to find an init.tcl file. + * + * $env(TCL_LIBRARY) - highest priority so user can always override + * the search path unless the application has + * specified an exact directory above + * + * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl + * on those platforms where it can determine + * at runtime the directory where it expects + * the init.tcl file to be. After [tclInit] + * reads and uses this value, it [unset]s it. + * External users of Tcl should not make use + * of the variable to customize [tclInit]. + * + * $tcl_libPath - OBSOLETE: This variable is no longer + * set by Tcl itself, but [tclInit] examines + * it in case some program that embeds Tcl + * is customizing [tclInit] by setting this + * variable to a list of directories in which + * to search. + * + * [tcl::pkgconfig get scriptdir,runtime] + * - the directory determined by configure to + * be the place where Tcl's script library + * is to be installed. + * + * The first directory on this path that contains a valid init.tcl script + * will be set as the value of tcl_library. + * + * Note that this entire search mechanism can be bypassed by defining an + * alternate tclInit procedure before calling Tcl_Init(). + */ + code = Tcl_Eval(interp, +"if {[info proc tclInit]==\"\"} {\n" +" proc tclInit {} {\n" +" global tcl_libPath tcl_library\n" +" global env tclDefaultLibrary\n" +" variable ::tcl::LibPath\n" +" rename tclInit {}\n" +" set errors {}\n" +" set localPath {}\n" +" set LibPath {}\n" +" if {[info exists tcl_library]} {\n" +" lappend localPath $tcl_library\n" +" } else {\n" +" if {[info exists env(TCL_LIBRARY)]\n" +" && [string length $env(TCL_LIBRARY)]} {\n" +" lappend localPath $env(TCL_LIBRARY)\n" +" lappend LibPath $env(TCL_LIBRARY)\n" +" if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n" +" if {$tail ne [info tclversion]} {\n" +" lappend localPath [file join [file dirname\\\n" +" $env(TCL_LIBRARY)] tcl[info tclversion]]\n" +" lappend LibPath [file join [file dirname\\\n" +" $env(TCL_LIBRARY)] tcl[info tclversion]]\n" +" }\n" +" }\n" +" }\n" +" if {[catch {\n" +" lappend localPath $tclDefaultLibrary\n" +" unset tclDefaultLibrary\n" +" }]} {\n" +" lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n" +" }\n" +" set parentDir [file normalize [file dirname [file dirname\\\n" +" [info nameofexecutable]]]]\n" +" set grandParentDir [file dirname $parentDir]\n" +" lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n" +" lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n" +" lappend LibPath [file join $parentDir library]\n" +" lappend LibPath [file join $grandParentDir library]\n" +" lappend LibPath [file join $grandParentDir\\\n" +" tcl[info patchlevel] library]\n" +" lappend LibPath [file join [file dirname $grandParentDir]\\\n" +" tcl[info patchlevel] library]\n" +" catch {\n" +" set LibPath [concat $LibPath $tcl_libPath]\n" +" }\n" +" }\n" +" foreach i [concat $localPath $LibPath] {\n" +" set tcl_library $i\n" +" set tclfile [file join $i init.tcl]\n" +" if {[file exists $tclfile]} {\n" +" if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n" +" return\n" +" } else {\n" +" append errors \"$tclfile: $msg\n\"\n" +" append errors \"[dict get $opts -errorinfo]\n\"\n" +" }\n" +" }\n" +" }\n" +" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n" +" append msg \" $localPath $LibPath\n\n\"\n" +" append msg \"$errors\n\n\"\n" +" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n" +" error $msg\n" +" }\n" +"}\n" +"tclInit"); + + if (code != TCL_OK) { + return code; + } + + /* + * Now that [info library] is initialized, make sure that + * [file join [info library] encoding] is on the encoding + * search path. + * + * Relying on use of original built-in commands. + * Should be a safe assumption during interp initialization. + * More robust would be to use C-coded equivalents, but that's such + * a pain... + */ + + Tcl_DStringInit(&script); + Tcl_DStringAppend(&script, "lsearch -exact", -1); + path = Tcl_DuplicateObj(TclGetEncodingSearchPath()); + Tcl_IncrRefCount(path); + Tcl_DStringAppendElement(&script, Tcl_GetString(path)); + Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1); + code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), + Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&script); + if (code == TCL_OK) { + int index; + Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index); + if (index != -1) { + /* [info library]/encoding already on the encoding search path */ + goto done; + } + } + Tcl_DStringInit(&script); + Tcl_DStringAppend(&script, "file join [info library] encoding", -1); + code = Tcl_EvalEx(interp, Tcl_DStringValue(&script), + Tcl_DStringLength(&script), TCL_EVAL_GLOBAL); + Tcl_DStringFree(&script); + if (code == TCL_OK) { + Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp)); + TclSetEncodingSearchPath(path); + } +done: + /* + * Now that we know the distributed *.enc files are on the encoding + * search path, check whether the [encoding system] matches that + * specified by the environment, and if not, attempt to correct it + */ + TclpGetEncodingNameFromEnvironment(&encodingName); + if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { + code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); + if (code == TCL_ERROR) { + Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName), + "\" not available"); + } + } + Tcl_DStringFree(&encodingName); + Tcl_DecrRefCount(path); + Tcl_ResetResult(interp); + return TCL_OK; } /* diff --git a/generic/tclNotify.c b/generic/tclNotify.c index 3f62d1a..e5a438f 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNotify.c,v 1.15 2004/07/15 21:17:03 vasiljevic Exp $ + * RCS: @(#) $Id: tclNotify.c,v 1.16 2004/11/30 19:34:49 dgp Exp $ */ #include "tclInt.h" @@ -81,7 +81,7 @@ static Tcl_ThreadDataKey dataKey; * be replaced with a hashtable. */ -static ThreadSpecificData *firstNotifierPtr; +static ThreadSpecificData *firstNotifierPtr = NULL; TCL_DECLARE_MUTEX(listLock) /* @@ -111,15 +111,22 @@ static void QueueEvent _ANSI_ARGS_((ThreadSpecificData *tsdPtr, void TclInitNotifier() { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr; + Tcl_ThreadId threadId = Tcl_GetCurrentThread(); Tcl_MutexLock(&listLock); - - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->clientData = tclStubs.tcl_InitNotifier(); - tsdPtr->nextPtr = firstNotifierPtr; - firstNotifierPtr = tsdPtr; - + for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId; + tsdPtr = tsdPtr->nextPtr) { + /* Empty loop body. */ + } + if (NULL == tsdPtr) { + /* Notifier not yet initialized in this thread */ + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->threadId = threadId; + tsdPtr->clientData = tclStubs.tcl_InitNotifier(); + tsdPtr->nextPtr = firstNotifierPtr; + firstNotifierPtr = tsdPtr; + } Tcl_MutexUnlock(&listLock); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index bfa7d86..c1c2dd0 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.107 2004/11/13 00:19:10 dgp Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.108 2004/11/30 19:34:49 dgp Exp $ */ #include "tclInt.h" @@ -293,6 +293,9 @@ TclIntStubs tclIntStubs = { TclpObjStat, /* 206 */ TclpObjAccess, /* 207 */ TclpOpenFileChannel, /* 208 */ + TclGetEncodingSearchPath, /* 209 */ + TclSetEncodingSearchPath, /* 210 */ + TclpGetEncodingNameFromEnvironment, /* 211 */ }; TclIntPlatStubs tclIntPlatStubs = { diff --git a/generic/tclTest.c b/generic/tclTest.c index c8006d4..c2f9dd0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.85 2004/10/07 22:01:18 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.86 2004/11/30 19:34:50 dgp Exp $ */ #define TCL_TEST @@ -1818,9 +1818,9 @@ TestencodingObjCmd(dummy, interp, objc, objv) } case ENC_PATH: { if (objc == 2) { - Tcl_SetObjResult(interp, TclGetLibraryPath()); + Tcl_SetObjResult(interp, TclGetEncodingSearchPath()); } else { - TclSetLibraryPath(objv[2]); + TclSetEncodingSearchPath(objv[2]); } break; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 068a20b..9737c4a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -11,23 +11,39 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUtil.c,v 1.48 2004/10/14 15:06:03 dkf Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.49 2004/11/30 19:34:50 dgp Exp $ */ #include "tclInt.h" /* - * The following variable holds the full path name of the binary + * The following variables hold the full path name of the binary * from which this application was executed, or NULL if it isn't - * know. The value of the variable is set by the procedure - * Tcl_FindExecutable. The storage space is dynamically allocated. + * know. The values are set by the procedure Tcl_FindExecutable. + * Only the first call to Tcl_FindExecutable sets the value. That + * call also sets the "searchDone" flag, so that subsequent calls + * are no-ops. With that logic in place, no mutex protection is + * required. The storage space is dynamically allocated. The value + * is kept in the system encoding. */ -char *tclExecutableName = NULL; char *tclNativeExecutableName = NULL; int tclFindExecutableSearchDone = 0; /* + * A copy of the executable path name, converted to Tcl's internal + * encoding, UTF-8. Also keep a copy of what the system encoding + * was believed to be when the conversion was done, just in case + * it's changed on us. Because Tcl_GetNameOfExecutable() is in + * the public API, it might be called from any thread, so we need + * mutex protection here. + */ + +TCL_DECLARE_MUTEX(executableNameMutex) +static char *executableName = NULL; +static Tcl_Encoding conversionEncoding = NULL; + +/* * The following values are used in the flags returned by Tcl_ScanElement * and used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value @@ -73,9 +89,16 @@ TCL_DECLARE_MUTEX(precisionMutex) * Prototypes for procedures defined later in this file. */ -static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); -static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, +static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr)); +static void FreeExecutableName _ANSI_ARGS_((ClientData)); +static void FreeProcessGlobalValue _ANSI_ARGS_(( + ClientData clientData)); +static void FreeThreadHash _ANSI_ARGS_ ((ClientData clientData)); +static Tcl_HashTable * GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr)); +static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objPtr)); +static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); +static Tcl_Obj * Tcl_GetObjNameOfExecutable(); /* * The following is the Tcl object type definition for an object @@ -2564,6 +2587,239 @@ TclCheckBadOctal(interp, value) /* *---------------------------------------------------------------------- * + * ClearHash -- + * Remove all the entries in the hash table *tablePtr. + * + *---------------------------------------------------------------------- + */ + +static void +ClearHash(tablePtr) + Tcl_HashTable *tablePtr; +{ + Tcl_HashSearch search; + Tcl_HashEntry *hPtr; + + for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; + hPtr = Tcl_NextHashEntry(&search)) { + Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + Tcl_DecrRefCount(objPtr); + Tcl_DeleteHashEntry(hPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * GetThreadHash -- + * + * Get a thread-specific (Tcl_HashTable *) associated with a + * thread data key. + * + * Results: + * The Tcl_HashTable * corresponding to *keyPtr. + * + * Side effects: + * The first call on a keyPtr in each thread creates a new + * Tcl_HashTable, and registers a thread exit handler to + * dispose of it. + * + *---------------------------------------------------------------------- + */ + +static Tcl_HashTable * +GetThreadHash(keyPtr) + Tcl_ThreadDataKey *keyPtr; +{ + Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **) + Tcl_GetThreadData(keyPtr, (int)sizeof(Tcl_HashTable *)); + if (NULL == *tablePtrPtr) { + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr); + Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); + } + return *tablePtrPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeThreadHash -- + * Thread exit handler used by GetThreadHash to dispose + * of a thread hash table. + * + * Side effects: + * Frees a Tcl_HashTable. + * + *---------------------------------------------------------------------- + */ + +static void +FreeThreadHash(clientData) + ClientData clientData; +{ + Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData; + Tcl_DeleteHashTable(tablePtr); + ckfree((char *) tablePtr); +} + +/* + *---------------------------------------------------------------------- + * + * FreeProcessGlobalValue -- + * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup + * a ProcessGlobalValue at exit. + * + *---------------------------------------------------------------------- + */ + +static void +FreeProcessGlobalValue(clientData) + ClientData clientData; +{ + ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData; + pgvPtr->epoch++; + pgvPtr->numBytes = 0; + ckfree(pgvPtr->value); + pgvPtr->value = NULL; + if (pgvPtr->encoding) { + Tcl_FreeEncoding(pgvPtr->encoding); + pgvPtr->encoding = NULL; + } + Tcl_MutexFinalize(&pgvPtr->mutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetProcessGlobalValue -- + * + * Utility routine to set a global value shared by all threads in + * the process while keeping a thread-local copy as well. + * + *---------------------------------------------------------------------- + */ +void +TclSetProcessGlobalValue(pgvPtr, newValue) + ProcessGlobalValue *pgvPtr; + Tcl_Obj *newValue; +{ + CONST char *bytes; + Tcl_HashTable *cacheMap; + Tcl_HashEntry *hPtr; + int dummy; + + Tcl_MutexLock(&pgvPtr->mutex); + /* Fill the global string value */ + pgvPtr->epoch++; + if (NULL != pgvPtr->value) { + ckfree(pgvPtr->value); + } else { + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + } + bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1); + strcpy(pgvPtr->value, bytes); + if (pgvPtr->encoding) { + Tcl_FreeEncoding(pgvPtr->encoding); + pgvPtr->encoding = NULL; + } + + /* + * Fill the local thread copy directly with the Tcl_Obj + * value to avoid loss of the intrep + */ + cacheMap = GetThreadHash(&pgvPtr->key); + ClearHash(cacheMap); + hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); + Tcl_SetHashValue(hPtr, (ClientData) newValue); + Tcl_IncrRefCount(newValue); + Tcl_MutexUnlock(&pgvPtr->mutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetProcessGlobalValue -- + * + * Retrieve a global value shared among all threads of the process, + * preferring a thread-local copy as long as it remains valid. + * + * Results: + * Returns a (Tcl_Obj *) that holds a copy of the global value. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetProcessGlobalValue(pgvPtr) + ProcessGlobalValue *pgvPtr; +{ + Tcl_Obj *value = NULL; + Tcl_HashTable *cacheMap; + Tcl_HashEntry *hPtr; + + Tcl_MutexLock(&pgvPtr->mutex); + if (pgvPtr->encoding) { + Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); + if (pgvPtr->encoding != current) { + + /* + * The system encoding has changed since the master + * string value was saved. Convert the master value + * to be based on the new system encoding. + */ + + Tcl_DString native, newValue; + + pgvPtr->epoch++; + Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, + pgvPtr->numBytes, &native); + Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), + Tcl_DStringLength(&native), &newValue); + Tcl_DStringFree(&native); + ckfree(pgvPtr->value); + pgvPtr->value = ckalloc((unsigned int) + Tcl_DStringLength(&newValue) + 1); + memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue),+ (size_t) Tcl_DStringLength(&newValue) + 1); + Tcl_DStringFree(&newValue); + Tcl_FreeEncoding(pgvPtr->encoding); + pgvPtr->encoding = current; + } else { + Tcl_FreeEncoding(current); + } + } + cacheMap = GetThreadHash(&pgvPtr->key); + hPtr = Tcl_FindHashEntry(cacheMap, (char *)pgvPtr->epoch); + if (NULL == hPtr) { + int dummy; + + /* No cache for the current epoch - must be a new one */ + /* First, clear the cacheMap, as anything in it must + * refer to some expired epoch.*/ + ClearHash(cacheMap); + + /* If no thread has set the shared value, call the initializer */ + if (NULL == pgvPtr->value) { + (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes, + &pgvPtr->encoding); + Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); + } + + + /* Store a copy of the shared value in our epoch-indexed cache */ + value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); + hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy); + Tcl_SetHashValue(hPtr, (ClientData) value); + Tcl_IncrRefCount(value); + } + Tcl_MutexUnlock(&pgvPtr->mutex); + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GetNameOfExecutable -- * * This procedure simply returns a pointer to the internal full @@ -2571,6 +2827,8 @@ TclCheckBadOctal(interp, value) * Tcl_FindExecutable. This procedure call is the C API * equivalent to the "info nameofexecutable" command. * + * TODO: Rework these routines to use a ProcessGlobalValue. + * * Results: * A pointer to the internal string or NULL if the internal full * path name has not been computed or unknown. @@ -2582,12 +2840,68 @@ TclCheckBadOctal(interp, value) *---------------------------------------------------------------------- */ +static void +FreeExecutableName(clientData) + ClientData clientData; +{ + Tcl_FreeEncoding(conversionEncoding); + conversionEncoding = NULL; + if (NULL != executableName) { + ckfree(executableName); + } + executableName = NULL; +} + +static Tcl_Obj * +Tcl_GetObjNameOfExecutable() +{ + Tcl_Obj *result; + + Tcl_MutexLock(&executableNameMutex); + if (NULL == conversionEncoding) { + /* First call (after free) */ + conversionEncoding = Tcl_GetEncoding(NULL, NULL); + Tcl_CreateExitHandler(FreeExecutableName, NULL); + } else { + /* Later call... */ + Tcl_Encoding systemEncoding = Tcl_GetEncoding(NULL, NULL); + if (systemEncoding != conversionEncoding) { + /* ...with system encoding changed */ + FreeExecutableName(NULL); + conversionEncoding = systemEncoding; + } else { + Tcl_FreeEncoding(systemEncoding); + } + } + if (NULL == tclNativeExecutableName) { + FreeExecutableName(NULL); + } else if (NULL == executableName) { + Tcl_DString ds; + Tcl_ExternalToUtfDString(conversionEncoding, + tclNativeExecutableName, -1, &ds); + executableName = (char *) + ckalloc ((unsigned) Tcl_DStringLength(&ds) + 1); + strcpy(executableName, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + } + + if (NULL == executableName) { + result = Tcl_NewObj(); + } else { + result = Tcl_NewStringObj(executableName, -1); + } + Tcl_MutexUnlock(&executableNameMutex); + return result; +} + CONST char * Tcl_GetNameOfExecutable() { - return tclExecutableName; + Tcl_DecrRefCount(Tcl_GetObjNameOfExecutable()); + return executableName; } + /* *---------------------------------------------------------------------- * diff --git a/tests/encoding.test b/tests/encoding.test index 97ae787..897bebf 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: encoding.test,v 1.20 2004/05/07 20:01:23 rmax Exp $ +# RCS: @(#) $Id: encoding.test,v 1.21 2004/11/30 19:34:51 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -95,7 +95,7 @@ test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} { foreach encoding [encoding names] { set encodings($encoding) 1 } - testencoding path [list [pwd]] + testencoding path [list [file join [pwd] encoding]] foreach encoding [encoding names] { if {![info exists encodings($encoding)]} { lappend x $encoding @@ -237,7 +237,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} { set path [testencoding path] encoding system identity cd [temporaryDirectory] - testencoding path tmp + testencoding path [file join tmp encoding] makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] diff --git a/tests/unixInit.test b/tests/unixInit.test index 22840fb..f42c868 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixInit.test,v 1.43 2004/11/22 21:24:31 dgp Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.44 2004/11/30 19:34:51 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -113,8 +113,15 @@ test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \ testsetdefenc $origDir set path } {slappy} -test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \ - {unix stdio } { +test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -constraints { + unix stdio +} -setup { + unset -nocomplain oldlibrary + if {[info exists env(TCL_LIBRARY)]} { + set oldlibrary $env(TCL_LIBRARY) + unset env(TCL_LIBRARY) + } +} -body { set path [getlibpath] set installLib lib/tcl[info tclversion] @@ -122,13 +129,19 @@ test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \ set prefix [file dirname [file dirname [interpreter]]] set x {} - lappend x [string compare [lindex $path 2] $prefix/$installLib] - lappend x [string compare [lindex $path 6] [file dirname $prefix]/$developLib] + lappend x [string compare [lindex $path 0] $prefix/$installLib] + lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib] set x -} {0 0} +} -cleanup { + if {[info exists oldlibrary]} { + set env(TCL_LIBRARY) $oldlibrary + unset oldlibrary + } +} -result {0 0} test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -constraints { unix stdio } -setup { + unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } @@ -149,6 +162,7 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -constraints { test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -constraints { unix stdio } -setup { + unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } @@ -167,7 +181,7 @@ test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -constraints } } -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -constraints { - unix stdio + unix stdio knownBug } -setup { if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) @@ -191,8 +205,14 @@ test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \ {emptyTest unix} { # cannot test } {} -test unixInit-2.6 {TclpInitLibraryPath: executable relative} \ - {unix stdio } { +test unixInit-2.6 {TclpInitLibraryPath: executable relative} -constraints { + unix stdio +} -setup { + unset -nocomplain oldlibrary + if {[info exists env(TCL_LIBRARY)]} { + set oldlibrary $env(TCL_LIBRARY) + } + set env(TCL_LIBRARY) [info library] makeDirectory tmp makeDirectory [file join tmp sparkly] makeDirectory [file join tmp sparkly bin] @@ -201,17 +221,23 @@ test unixInit-2.6 {TclpInitLibraryPath: executable relative} \ makeDirectory [file join tmp sparkly lib] makeDirectory [file join tmp sparkly lib tcl[info tclversion]] makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl] - - set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \ - bin tcltest]] 2 3] +} -body { + lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \ + bin tcltest]] 1 2 +} -cleanup { removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl] removeDirectory [file join tmp sparkly lib tcl[info tclversion]] removeDirectory [file join tmp sparkly lib] removeDirectory [file join tmp sparkly bin] removeDirectory [file join tmp sparkly] removeDirectory tmp - set x -} [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] + unset env(TCL_LIBRARY) + if {[info exists oldlibrary]} { + set env(TCL_LIBRARY) $oldlibrary + unset oldlibrary + } +} -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] + test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \ {emptyTest unix} { # would need test command to get defaultLibDir and compare it to @@ -226,7 +252,14 @@ test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \ testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}] testConstraint noTmpInstall [expr {![file exists \ [file join /tmp lib tcl[info tclversion]]]}] -test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall } { +test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -constraints { + unix noSparkly noTmpInstall +} -setup { + unset -nocomplain oldlibrary + if {[info exists env(TCL_LIBRARY)]} { + set oldlibrary $env(TCL_LIBRARY) + } + set env(TCL_LIBRARY) [info library] # Checking for Bug 219416 # When a program that embeds the Tcl library, like tcltest, is # installed near the "root" of the file system, there was a problem @@ -261,6 +294,7 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly n # ../lib/tcl$version relative to the executable. file mkdir /tmp/lib/tcl[info tclversion] close [open /tmp/lib/tcl[info tclversion]/init.tcl w] +} -body { # Check that all directories in the library path are absolute pathnames set allAbsolute 1 @@ -268,16 +302,29 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly n set allAbsolute [expr {$allAbsolute \ && [string equal absolute [file pathtype $dir]]}] } + set allAbsolute +} -cleanup { # Clean up temporary installation file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] if {$deletelib} {file delete -force /tmp/lib} - set allAbsolute -} 1 + unset env(TCL_LIBRARY) + if {[info exists oldlibrary]} { + set env(TCL_LIBRARY) $oldlibrary + unset oldlibrary + } +} -result 1 testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}] -test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild } { +test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -constraints { + unix noSparkly noTmpBuild +} -setup { # Checking for Bug 438014 + unset -nocomplain oldlibrary + if {[info exists env(TCL_LIBRARY)]} { + set oldlibrary $env(TCL_LIBRARY) + } + set env(TCL_LIBRARY) [info library] file delete -force /tmp/sparkly file delete -force /tmp/library file mkdir /tmp/sparkly @@ -285,18 +332,27 @@ test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSp file mkdir /tmp/library/ close [open /tmp/library/init.tcl w] - - set x [lrange [getlibpath /tmp/sparkly/tcltest] 2 6] - +} -body { + lrange [getlibpath /tmp/sparkly/tcltest] 1 5 +} -cleanup { file delete -force /tmp/sparkly file delete -force /tmp/library - set x -} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ + unset env(TCL_LIBRARY) + if {[info exists oldlibrary]} { + set env(TCL_LIBRARY) $oldlibrary + unset oldlibrary + } +} -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ /tmp/library /library /tcl[info patchlevel]/library] test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints { unix stdio } -setup { + unset -nocomplain oldlibrary + if {[info exists env(TCL_LIBRARY)]} { + set oldlibrary $env(TCL_LIBRARY) + } + set env(TCL_LIBRARY) [info library] set tmpDir [makeDirectory tmp] set sparklyDir [makeDirectory sparkly $tmpDir] set execPath [file join [makeDirectory bin $sparklyDir] tcltest] @@ -308,7 +364,7 @@ test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints { cd $libDir } -body { # Checking for Bug 832657 - set x [lrange [getlibpath [file join .. bin tcltest]] 4 5] + set x [lrange [getlibpath [file join .. bin tcltest]] 3 4] foreach p $x { lappend y [file normalize $p] } @@ -329,6 +385,11 @@ test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints { unset tmpDir removeDirectory tmp unset x p y + unset env(TCL_LIBRARY) + if {[info exists oldlibrary]} { + set env(TCL_LIBRARY) $oldlibrary + unset oldlibrary + } } -result [list [file join [temporaryDirectory] tmp sparkly library] \ [file join [temporaryDirectory] tmp library] ] diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index 842d1b6..421ea16 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixFile.c,v 1.42 2004/10/07 14:50:23 vincentdarley Exp $ + * RCS: @(#) $Id: tclUnixFile.c,v 1.43 2004/11/30 19:34:51 dgp Exp $ */ #include "tclInt.h" @@ -42,7 +42,7 @@ static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); *--------------------------------------------------------------------------- */ -char * +void TclpFindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ @@ -50,13 +50,13 @@ TclpFindExecutable(argv0) CONST char *name, *p; Tcl_StatBuf statBuf; int length; - Tcl_DString buffer, nameString; + Tcl_DString buffer, nameString, cwd; if (argv0 == NULL) { - return NULL; + return; } if (tclFindExecutableSearchDone) { - return tclNativeExecutableName; + return; } tclFindExecutableSearchDone = 1; @@ -135,7 +135,7 @@ TclpFindExecutable(argv0) goto done; /* - * If the name starts with "/" then just copy it to tclExecutableName. + * If the name starts with "/" then just copy it to tclNativeExecutableName. */ gotName: @@ -144,11 +144,9 @@ gotName: #else if (name[0] == '/') { #endif - Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); tclNativeExecutableName = (char *) - ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1)); - strcpy(tclNativeExecutableName, Tcl_DStringValue(&nameString)); - Tcl_DStringFree(&nameString); + ckalloc((unsigned int) strlen(name) + 1); + strcpy(tclNativeExecutableName, name); goto done; } @@ -162,22 +160,29 @@ gotName: name += 2; } - Tcl_ExternalToUtfDString(NULL, name, -1, &nameString); + Tcl_DStringInit(&nameString); + Tcl_DStringAppend(&nameString, name, -1); + + TclpGetCwd(NULL, &cwd); Tcl_DStringFree(&buffer); - TclpGetCwd(NULL, &buffer); + Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&cwd), + Tcl_DStringLength(&cwd), &buffer); + if (Tcl_DStringValue(&cwd)[Tcl_DStringLength(&cwd) -1] != '/') { + Tcl_DStringAppend(&buffer, "/", 1); + } + Tcl_DStringFree(&cwd); + Tcl_DStringAppend(&buffer, Tcl_DStringValue(&nameString), + Tcl_DStringLength(&nameString)); + Tcl_DStringFree(&nameString); - length = Tcl_DStringLength(&buffer) + Tcl_DStringLength(&nameString) + 2; + length = Tcl_DStringLength(&buffer) + 1; tclNativeExecutableName = (char *) ckalloc((unsigned) length); strcpy(tclNativeExecutableName, Tcl_DStringValue(&buffer)); - tclNativeExecutableName[Tcl_DStringLength(&buffer)] = '/'; - strcpy(tclNativeExecutableName + Tcl_DStringLength(&buffer) + 1, - Tcl_DStringValue(&nameString)); - Tcl_DStringFree(&nameString); done: Tcl_DStringFree(&buffer); - return tclNativeExecutableName; + Tcl_GetNameOfExecutable(); } /* diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 3592c17..4dd3208 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclUnixInit.c,v 1.52 2004/11/22 22:13:40 dgp Exp $ + * RCS: @(#) $Id: tclUnixInit.c,v 1.53 2004/11/30 19:34:51 dgp Exp $ */ #include "tclInt.h" @@ -93,11 +93,6 @@ static Tcl_ThreadDataKey dataKey; #define STACK_DEBUG(args) (void)0 #endif /* TCL_DEBUG_STACK_CHECK */ -/* Used to store the encoding used for binary files */ -static Tcl_Encoding binaryEncoding = NULL; -/* Has the basic library path encoding issue been fixed */ -static int libraryPathEncodingFixed = 0; - /* * Tcl tries to use standard and homebrew methods to guess the right * encoding on the platform. However, there is always a final fallback, @@ -137,6 +132,147 @@ typedef struct LocaleTable { } LocaleTable; static CONST LocaleTable localeTable[] = { + /* First list all the encoding files installed with Tcl */ + {"ascii", "ascii"}, + {"big5", "big5"}, + {"cp1250", "cp1250"}, + {"cp1251", "cp1251"}, + {"cp1252", "cp1252"}, + {"cp1253", "cp1253"}, + {"cp1254", "cp1254"}, + {"cp1255", "cp1255"}, + {"cp1256", "cp1256"}, + {"cp1257", "cp1257"}, + {"cp1258", "cp1258"}, + {"cp437", "cp437"}, + {"cp737", "cp737"}, + {"cp775", "cp775"}, + {"cp850", "cp850"}, + {"cp852", "cp852"}, + {"cp855", "cp855"}, + {"cp857", "cp857"}, + {"cp860", "cp860"}, + {"cp861", "cp861"}, + {"cp862", "cp862"}, + {"cp863", "cp863"}, + {"cp864", "cp864"}, + {"cp865", "cp865"}, + {"cp866", "cp866"}, + {"cp869", "cp869"}, + {"cp874", "cp874"}, + {"cp932", "cp932"}, + {"cp936", "cp936"}, + {"cp949", "cp949"}, + {"cp950", "cp950"}, + {"dingbats", "dingbats"}, + {"ebcdic", "ebcdic"}, + {"euc-cn", "euc-cn"}, + {"euc-jp", "euc-jp"}, + {"euc-kr", "euc-kr"}, + {"gb12345", "gb12345"}, + {"gb1988", "gb1988"}, + {"gb2312-raw", "gb2312-raw"}, + {"gb2312", "gb2312"}, + {"iso2022-jp", "iso2022-jp"}, + {"iso2022-kr", "iso2022-kr"}, + {"iso2022", "iso2022"}, + {"iso8859-1", "iso8859-1"}, + {"iso8859-10", "iso8859-10"}, + {"iso8859-13", "iso8859-13"}, + {"iso8859-14", "iso8859-14"}, + {"iso8859-15", "iso8859-15"}, + {"iso8859-16", "iso8859-16"}, + {"iso8859-2", "iso8859-2"}, + {"iso8859-3", "iso8859-3"}, + {"iso8859-4", "iso8859-4"}, + {"iso8859-5", "iso8859-5"}, + {"iso8859-6", "iso8859-6"}, + {"iso8859-7", "iso8859-7"}, + {"iso8859-8", "iso8859-8"}, + {"iso8859-9", "iso8859-9"}, + {"jis0201", "jis0201"}, + {"jis0208", "jis0208"}, + {"jis0212", "jis0212"}, + {"koi8-r", "koi8-r"}, + {"koi8-u", "koi8-u"}, + {"ksc5601", "ksc5601"}, + {"macCentEuro", "macCentEuro"}, + {"macCroatian", "macCroatian"}, + {"macCyrillic", "macCyrillic"}, + {"macDingbats", "macDingbats"}, + {"macGreek", "macGreek"}, + {"macIceland", "macIceland"}, + {"macJapan", "macJapan"}, + {"macRoman", "macRoman"}, + {"macRomania", "macRomania"}, + {"macThai", "macThai"}, + {"macTurkish", "macTurkish"}, + {"macUkraine", "macUkraine"}, + {"shiftjis", "shiftjis"}, + {"symbol", "symbol"}, + {"tis-620", "tis-620"}, + /* Next list a few common variants */ + {"maccenteuro", "macCentEuro"}, + {"maccroatian", "macCroatian"}, + {"maccyrillic", "macCyrillic"}, + {"macdingbats", "macDingbats"}, + {"macgreek", "macGreek"}, + {"maciceland", "macIceland"}, + {"macjapan", "macJapan"}, + {"macroman", "macRoman"}, + {"macromania", "macRomania"}, + {"macthai", "macThai"}, + {"macturkish", "macTurkish"}, + {"macukraine", "macUkraine"}, + {"iso-2022-jp", "iso2022-jp"}, + {"iso-2022-kr", "iso2022-kr"}, + {"iso-2022", "iso2022"}, + {"iso-8859-1", "iso8859-1"}, + {"iso-8859-10", "iso8859-10"}, + {"iso-8859-13", "iso8859-13"}, + {"iso-8859-14", "iso8859-14"}, + {"iso-8859-15", "iso8859-15"}, + {"iso-8859-16", "iso8859-16"}, + {"iso-8859-2", "iso8859-2"}, + {"iso-8859-3", "iso8859-3"}, + {"iso-8859-4", "iso8859-4"}, + {"iso-8859-5", "iso8859-5"}, + {"iso-8859-6", "iso8859-6"}, + {"iso-8859-7", "iso8859-7"}, + {"iso-8859-8", "iso8859-8"}, + {"iso-8859-9", "iso8859-9"}, + {"ibm1250", "cp1250"}, + {"ibm1251", "cp1251"}, + {"ibm1252", "cp1252"}, + {"ibm1253", "cp1253"}, + {"ibm1254", "cp1254"}, + {"ibm1255", "cp1255"}, + {"ibm1256", "cp1256"}, + {"ibm1257", "cp1257"}, + {"ibm1258", "cp1258"}, + {"ibm437", "cp437"}, + {"ibm737", "cp737"}, + {"ibm775", "cp775"}, + {"ibm850", "cp850"}, + {"ibm852", "cp852"}, + {"ibm855", "cp855"}, + {"ibm857", "cp857"}, + {"ibm860", "cp860"}, + {"ibm861", "cp861"}, + {"ibm862", "cp862"}, + {"ibm863", "cp863"}, + {"ibm864", "cp864"}, + {"ibm865", "cp865"}, + {"ibm866", "cp866"}, + {"ibm869", "cp869"}, + {"ibm874", "cp874"}, + {"ibm932", "cp932"}, + {"ibm936", "cp936"}, + {"ibm949", "cp949"}, + {"ibm950", "cp950"}, + {"", "iso8859-1"}, + {"ansi_x3.4-1968", "iso8859-1"}, + /* Finally, the accumulated bug fixes... */ #ifdef HAVE_LANGINFO {"gb2312-1980", "gb2312"}, #ifdef __hpux @@ -280,6 +416,25 @@ TclpInitPlatform() */ (void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */ #endif + /* + * Initialize the C library's locale subsystem. This is required + * for input methods to work properly on X11. We only do this for + * LC_CTYPE because that's the necessary one, and we don't want to + * affect LC_TIME here. The side effect of setting the default + * locale should be to load any locale specific modules that are + * needed by X. [BUG: 5422 3345 4236 2522 2521]. + */ + + setlocale(LC_CTYPE, ""); + + /* + * In case the initial locale is not "C", ensure that the numeric + * processing is done in "C" locale regardless. This is needed because + * Tcl relies on routines like strtod, but should not have locale + * dependent behavior. + */ + + setlocale(LC_NUMERIC, "C"); } /* @@ -287,47 +442,24 @@ TclpInitPlatform() * * TclpInitLibraryPath -- * - * Initialize the library path at startup. We have a minor - * metacircular problem that we don't know the encoding of the - * operating system but we may need to talk to operating system - * to find the library directories so that we know how to talk to - * the operating system. - * - * We do not know the encoding of the operating system. - * We do know that the encoding is some multibyte encoding. - * In that multibyte encoding, the characters 0..127 are equivalent - * to ascii. - * - * So although we don't know the encoding, it's safe: - * to look for the last slash character in a path in the encoding. - * to append an ascii string to a path. - * to pass those strings back to the operating system. - * - * But any strings that we remembered before we knew the encoding of - * the operating system must be translated to UTF-8 once we know the - * encoding so that the rest of Tcl can use those strings. - * - * This call sets the library path to strings in the unknown native - * encoding. TclpSetInitialEncodings() will translate the library - * path from the native encoding to UTF-8 as soon as it determines - * what the native encoding actually is. - * - * Called at process initialization time. + * This is the fallback routine that sets the library path + * if the application has not set one by the first time + * it is needed. * * Results: - * Return 1, indicating that the UTF may be dirty and require "cleanup" - * after encodings are initialized. + * None. * * Side effects: - * None. + * Sets the library path to an initial value. * - *--------------------------------------------------------------------------- - */ + *------------------------------------------------------------------------- + */ -int -TclpInitLibraryPath(path) -CONST char *path; /* Path to the executable in native - * multi-byte encoding. */ +void +TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; @@ -349,16 +481,6 @@ CONST char *path; /* Path to the executable in native sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* - * Look for the library relative to default encoding dir. - */ - - str = Tcl_GetDefaultEncodingDir(); - if ((str != NULL) && (str[0] != '\0')) { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } - - /* * Look for the library relative to the TCL_LIBRARY env variable. * If the last dirname in the TCL_LIBRARY path does not match the * last dirname in the installLib variable, use the last dir name @@ -411,6 +533,7 @@ CONST char *path; /* Path to the executable in native } else #endif /* HAVE_CFBUNDLE */ { + /* TODO: Pull this value from the TIP 59 table */ str = defaultLibraryDir; } if (str[0] != '\0') { @@ -418,11 +541,13 @@ CONST char *path; /* Path to the executable in native Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); } } - - TclSetLibraryPath(pathPtr); Tcl_DStringFree(&buffer); - return 1; /* 1 indicates that pathPtr may be dirty utf (needs cleaning) */ + *encodingPtr = Tcl_GetEncoding(NULL, NULL); + str = Tcl_GetStringFromObj(pathPtr, lengthPtr); + *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); + memcpy((VOID *) *valuePtr, (VOID *) str, (size_t)(*lengthPtr)+1); + Tcl_DecrRefCount(pathPtr); } /* @@ -452,223 +577,125 @@ CONST char *path; /* Path to the executable in native void TclpSetInitialEncodings() { - if (libraryPathEncodingFixed == 0) { - CONST char *encoding = NULL; - int i, setSysEncCode = TCL_ERROR; - Tcl_Obj *pathPtr; - - /* - * Determine the current encoding from the LC_* or LANG environment - * variables. We previously used setlocale() to determine the locale, - * but this does not work on some systems (e.g. Linux/i386 RH 5.0). - */ -#ifdef HAVE_LANGINFO - if (setlocale(LC_CTYPE, "") != NULL) { - Tcl_DString ds; - - /* - * Use a DString so we can overwrite it in name compatability - * checks below. - */ + Tcl_DString encodingName; + Tcl_SetSystemEncoding(NULL, + TclpGetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} - Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); +CONST char * +TclpGetEncodingNameFromEnvironment(bufPtr) + Tcl_DString *bufPtr; +{ + CONST char *encoding; + int i; - Tcl_UtfToLower(Tcl_DStringValue(&ds)); -#ifdef HAVE_LANGINFO_DEBUG - fprintf(stderr, "encoding '%s'", encoding); -#endif - if (encoding[0] == 'i' && encoding[1] == 's' && encoding[2] == 'o' - && encoding[3] == '-') { - char *p, *q; - /* need to strip '-' from iso-* encoding */ - for(p = Tcl_DStringValue(&ds)+3, q = Tcl_DStringValue(&ds)+4; - *p; *p++ = *q++); - } else if (encoding[0] == 'i' && encoding[1] == 'b' - && encoding[2] == 'm' && encoding[3] >= '0' - && encoding[3] <= '9') { - char *p, *q; - /* if langinfo reports "ibm*" we should use "cp*" */ - p = Tcl_DStringValue(&ds); - *p++ = 'c'; *p++ = 'p'; - for(q = p+1; *p ; *p++ = *q++); - } else if ((*encoding == '\0') - || !strcmp(encoding, "ansi_x3.4-1968")) { - /* Use iso8859-1 for empty or 'ansi_x3.4-1968' encoding */ - encoding = "iso8859-1"; - } -#ifdef HAVE_LANGINFO_DEBUG - fprintf(stderr, " ?%s?", encoding); -#endif - setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding); - if (setSysEncCode != TCL_OK) { - /* - * If this doesn't return TCL_OK, the encoding returned by - * nl_langinfo or as we translated it wasn't accepted. Do - * this fallback check. If this fails, we will enter the - * old fallback below. - */ + Tcl_DStringInit(bufPtr); - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, encoding) == 0) { - setSysEncCode = Tcl_SetSystemEncoding(NULL, - localeTable[i].encoding); - break; - } + /* + * Determine the current encoding from the LC_* or LANG environment + * variables. We previously used setlocale() to determine the locale, + * but this does not work on some systems (e.g. Linux/i386 RH 5.0). + */ +#ifdef HAVE_LANGINFO + if (setlocale(LC_CTYPE, "") != NULL) { + Tcl_DString ds; + + /* Use a DString so we can modify case. */ + Tcl_DStringInit(&ds); + encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1); + Tcl_UtfToLower(Tcl_DStringValue(&ds)); + /* Check whether it's a known encoding... */ + if (NULL == Tcl_GetEncoding(NULL, encoding)) { + /* ... or in the table if encodings we *should* know */ + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, encoding) == 0) { + Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); + break; } } -#ifdef HAVE_LANGINFO_DEBUG - fprintf(stderr, " => '%s'\n", encoding); -#endif - Tcl_DStringFree(&ds); + } else { + Tcl_DStringAppend(bufPtr, encoding, -1); } -#ifdef HAVE_LANGINFO_DEBUG - else { - fprintf(stderr, "setlocale returned NULL\n"); + Tcl_DStringFree(&ds); + if (Tcl_DStringLength(bufPtr)) { + return Tcl_DStringValue(bufPtr); } -#endif + } #endif /* HAVE_LANGINFO */ - if (setSysEncCode != TCL_OK) { - /* - * Classic fallback check. This tries a homebrew algorithm to - * determine what encoding should be used based on env vars. - */ - char *langEnv = getenv("LC_ALL"); - encoding = NULL; + /* + * Classic fallback check. This tries a homebrew algorithm to + * determine what encoding should be used based on env vars. + */ + encoding = getenv("LC_ALL"); - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LC_CTYPE"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = getenv("LANG"); - } - if (langEnv == NULL || langEnv[0] == '\0') { - langEnv = NULL; - } + if (encoding == NULL || encoding[0] == '\0') { + encoding = getenv("LC_CTYPE"); + } + if (encoding == NULL || encoding[0] == '\0') { + encoding = getenv("LANG"); + } + if (encoding == NULL || encoding[0] == '\0') { + encoding = NULL; + } - if (langEnv != NULL) { - for (i = 0; localeTable[i].lang != NULL; i++) { - if (strcmp(localeTable[i].lang, langEnv) == 0) { - encoding = localeTable[i].encoding; - break; - } - } - /* - * There was no mapping in the locale table. If there is an - * encoding subfield, we can try to guess from that. - */ - - if (encoding == NULL) { - char *p; - for (p = langEnv; *p != '\0'; p++) { - if (*p == '.') { - p++; - break; - } - } - if (*p != '\0') { - Tcl_DString ds; - Tcl_DStringInit(&ds); - encoding = Tcl_DStringAppend(&ds, p, -1); - - Tcl_UtfToLower(Tcl_DStringValue(&ds)); - setSysEncCode = Tcl_SetSystemEncoding(NULL, encoding); - if (setSysEncCode != TCL_OK) { - encoding = NULL; - } - Tcl_DStringFree(&ds); - } - } -#ifdef HAVE_LANGINFO_DEBUG - fprintf(stderr, "encoding fallback check '%s' => '%s'\n", - langEnv, encoding); -#endif - } - if (setSysEncCode != TCL_OK) { - if (encoding == NULL) { - encoding = TCL_DEFAULT_ENCODING; - } + if (encoding != NULL) { + CONST char *p; - Tcl_SetSystemEncoding(NULL, encoding); + /* Check whether it's a known encoding... */ + if (NULL == Tcl_GetEncoding(NULL, encoding)) { + /* ... or in the table if encodings we *should* know */ + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, encoding) == 0) { + Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); + break; + } } - - /* - * Initialize the C library's locale subsystem. This is required - * for input methods to work properly on X11. We only do this for - * LC_CTYPE because that's the necessary one, and we don't want to - * affect LC_TIME here. The side effect of setting the default - * locale should be to load any locale specific modules that are - * needed by X. [BUG: 5422 3345 4236 2522 2521]. - * In HAVE_LANGINFO, this call is already done above. - */ -#ifndef HAVE_LANGINFO - setlocale(LC_CTYPE, ""); -#endif + } else { + Tcl_DStringAppend(bufPtr, encoding, -1); + } + if (Tcl_DStringLength(bufPtr)) { + return Tcl_DStringValue(bufPtr); } /* - * In case the initial locale is not "C", ensure that the numeric - * processing is done in "C" locale regardless. This is needed because - * Tcl relies on routines like strtod, but should not have locale - * dependent behavior. - */ - - setlocale(LC_NUMERIC, "C"); - - /* - * Until the system encoding was actually set, the library path was - * actually in the native multi-byte encoding, and not really UTF-8 - * as advertised. We cheated as follows: - * - * 1. It was safe to allow the Tcl_SetSystemEncoding() call to - * append the ASCII chars that make up the encoding's filename to - * the names (in the native encoding) of directories in the library - * path, since all Unix multi-byte encodings have ASCII in the - * beginning. - * - * 2. To open the encoding file, the native bytes in the file name - * were passed to the OS, without translating from UTF-8 to native, - * because the name was already in the native encoding. - * - * Now that the system encoding was actually successfully set, - * translate all the names in the library path to UTF-8. That way, - * next time we search the library path, we'll translate the names - * from UTF-8 to the system encoding which will be the native - * encoding. + * We didn't recognize the full value as an encoding name. + * If there is an encoding subfield, we can try to guess from that. */ - pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); + for (p = encoding; *p != '\0'; p++) { + if (*p == '.') { + p++; + break; } } + if (*p != '\0') { + Tcl_DString ds; + Tcl_DStringInit(&ds); + encoding = Tcl_DStringAppend(&ds, p, -1); + Tcl_UtfToLower(Tcl_DStringValue(&ds)); - libraryPathEncodingFixed = 1; - } + /* Check whether it's a known encoding... */ + if (NULL == Tcl_GetEncoding(NULL, encoding)) { + /* ... or in the table if encodings we *should* know */ + for (i = 0; localeTable[i].lang != NULL; i++) { + if (strcmp(localeTable[i].lang, encoding) == 0) { + Tcl_DStringAppend(bufPtr, localeTable[i].encoding, -1); + break; + } + } + } else { + Tcl_DStringAppend(bufPtr, encoding, -1); + } + Tcl_DStringFree(&ds); + if (Tcl_DStringLength(bufPtr)) { + return Tcl_DStringValue(bufPtr); + } - /* This is only ever called from the startup thread */ - if (binaryEncoding == NULL) { - /* - * Keep the iso8859-1 encoding preloaded. The IO package uses - * it for gets on a binary channel. - */ - binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + } } + return Tcl_DStringAppend(bufPtr, TCL_DEFAULT_ENCODING, -1); } /* diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 955f719..9b5c717 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixTest.c,v 1.18 2004/06/18 20:38:02 dgp Exp $ + * RCS: @(#) $Id: tclUnixTest.c,v 1.19 2004/11/30 19:34:51 dgp Exp $ */ #include "tclInt.h" @@ -444,7 +444,6 @@ TestfindexecutableCmd(clientData, interp, argc, argv) int argc; /* Number of arguments. */ CONST char **argv; /* Argument strings. */ { - char *oldName; char *oldNativeName; int oldDone; @@ -454,24 +453,19 @@ TestfindexecutableCmd(clientData, interp, argc, argv) return TCL_ERROR; } - oldName = tclExecutableName; oldNativeName = tclNativeExecutableName; oldDone = tclFindExecutableSearchDone; - tclExecutableName = NULL; tclNativeExecutableName = NULL; tclFindExecutableSearchDone = 0; + Tcl_GetNameOfExecutable(); Tcl_FindExecutable(argv[1]); - if (tclExecutableName != NULL) { - Tcl_SetResult(interp, tclExecutableName, TCL_VOLATILE); - ckfree(tclExecutableName); - } + Tcl_SetResult(interp, (char *) Tcl_GetNameOfExecutable(), TCL_VOLATILE); if (tclNativeExecutableName != NULL) { ckfree(tclNativeExecutableName); } - tclExecutableName = oldName; tclNativeExecutableName = oldNativeName; tclFindExecutableSearchDone = oldDone; @@ -529,7 +523,7 @@ TestgetopenfileCmd(clientData, interp, argc, argv) * TestsetdefencdirCmd -- * * This procedure implements the "testsetdefenc" command. It is - * used to set the value of tclDefaultEncodingDir. + * used to test Tcl_SetDefaultEncodingDir(). * * Results: * A standard Tcl result. @@ -555,15 +549,7 @@ TestsetdefencdirCmd(clientData, interp, argc, argv) return TCL_ERROR; } - if (tclDefaultEncodingDir != NULL) { - ckfree(tclDefaultEncodingDir); - tclDefaultEncodingDir = NULL; - } - if (*argv[1] != '\0') { - tclDefaultEncodingDir = (char *) - ckalloc((unsigned) strlen(argv[1]) + 1); - strcpy(tclDefaultEncodingDir, argv[1]); - } + Tcl_SetDefaultEncodingDir(argv[1]); return TCL_OK; } @@ -573,7 +559,7 @@ TestsetdefencdirCmd(clientData, interp, argc, argv) * TestgetdefencdirCmd -- * * This procedure implements the "testgetdefenc" command. It is - * used to get the value of tclDefaultEncodingDir. + * used to test Tcl_GetDefaultEncodingDir(). * * Results: * A standard Tcl result. @@ -598,9 +584,7 @@ TestgetdefencdirCmd(clientData, interp, argc, argv) return TCL_ERROR; } - if (tclDefaultEncodingDir != NULL) { - Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL); - } + Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), (char *) NULL); return TCL_OK; } diff --git a/win/tclWinFile.c b/win/tclWinFile.c index ca2eeba..8c39505 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinFile.c,v 1.70 2004/11/02 12:13:36 vincentdarley Exp $ + * RCS: @(#) $Id: tclWinFile.c,v 1.71 2004/11/30 19:34:51 dgp Exp $ */ //#define _WIN32_WINNT 0x0500 @@ -691,19 +691,20 @@ NativeWriteReparse(LinkDirectory, buffer) *--------------------------------------------------------------------------- */ -char * +void TclpFindExecutable(argv0) CONST char *argv0; /* The value of the application's argv[0] * (native). */ { WCHAR wName[MAX_PATH]; char name[MAX_PATH * TCL_UTF_MAX]; + Tcl_DString ds; if (argv0 == NULL) { - return NULL; + return; } if (tclNativeExecutableName != NULL) { - return tclNativeExecutableName; + return; } /* @@ -719,12 +720,13 @@ TclpFindExecutable(argv0) MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); } WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); + TclWinNoBackslash(name); - tclNativeExecutableName = ckalloc((unsigned) (strlen(name) + 1)); - strcpy(tclNativeExecutableName, name); - - TclWinNoBackslash(tclNativeExecutableName); - return tclNativeExecutableName; + Tcl_UtfToExternalDString(NULL, name, -1, &ds); + tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1)); + strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + Tcl_GetNameOfExecutable(); } /* diff --git a/win/tclWinInit.c b/win/tclWinInit.c index c92eab6..0b54cdb 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -7,7 +7,7 @@ * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * - * RCS: @(#) $Id: tclWinInit.c,v 1.63 2004/11/24 21:12:20 kennykb Exp $ + * RCS: @(#) $Id: tclWinInit.c,v 1.64 2004/11/30 19:34:52 dgp Exp $ */ #include "tclWinInt.h" @@ -92,167 +92,15 @@ static char* processors[NUMPROCESSORS] = { "amd64", "ia32_on_win64" }; -/* Used to store the encoding used for binary files */ -static Tcl_Encoding binaryEncoding = NULL; -/* Has the basic library path encoding issue been fixed */ -static int libraryPathEncodingFixed = 0; - -static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); -static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule, - CONST char *lib); -static void FreeDefaultLibraryDir(ClientData); -static void FreeThreadDefaultLibraryDir(ClientData); -static Tcl_Obj * GetDefaultLibraryDir(); -static void SetDefaultLibraryDir(Tcl_Obj *directory); -static int ToUtf(CONST WCHAR *wSrc, char *dst); - -/* - *--------------------------------------------------------------------------- - * - * SetDefaultLibraryDir -- - * - * Called by TclpInitLibraryPath to save the path to the - * directory ../lib/tcl<version> relative to the Tcl Dll. - * - * Results: - * None. - * - * Side effects: - * Saves a per-thread (Tcl_Obj *) and a per-process string. - * Sets up exit handlers to free them. - * - *--------------------------------------------------------------------------- - */ - /* - * Per-process copy of the default library dir, as a string, shared by - * all threads + * The default directory in which the init.tcl file is expected to be found. */ -static char *defaultLibraryDir = NULL; -static int defaultLibraryDirLength = 0; -static Tcl_ThreadDataKey defaultLibraryDirKey; - -static void -FreeThreadDefaultLibraryDir(clientData) - ClientData clientData; -{ - Tcl_Obj **objPtrPtr = (Tcl_Obj **) clientData; - Tcl_DecrRefCount(*objPtrPtr); -} - -static void -FreeDefaultLibraryDir(clientData) - ClientData clientData; -{ - ckfree(defaultLibraryDir); - defaultLibraryDir = NULL; - defaultLibraryDirLength = 0; -} - -static void -SetDefaultLibraryDir(directory) - Tcl_Obj *directory; -{ - int numBytes = 0; - CONST char *bytes; - Tcl_Obj **savedDirectoryPtr = (Tcl_Obj **) - Tcl_GetThreadData(&defaultLibraryDirKey, (int) sizeof(Tcl_Obj *)); +static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; +static ProcessGlobalValue defaultLibraryDir = + {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; - Tcl_IncrRefCount(directory); - if (*savedDirectoryPtr == NULL) { - /* - * First call in this thread, set up the thread exit handler - */ - Tcl_CreateThreadExitHandler(FreeThreadDefaultLibraryDir, - (ClientData) savedDirectoryPtr); - } else { - /* - * Called SetDLD after a previous SetDLD or GetDLD in this thread ?! - */ - Tcl_DecrRefCount(*savedDirectoryPtr); - } - *savedDirectoryPtr = directory; - - /* - * No Mutex protection, as the only caller is already in TclpInitLock - */ - - bytes = Tcl_GetStringFromObj(directory, &numBytes); - if (defaultLibraryDir != NULL) { - /* - * This function has been called before. We only ever want to - * set up the default library directory once, but if it is set - * multiple times to the same value that's not harmful. - */ - if (defaultLibraryDirLength != numBytes || - memcmp(defaultLibraryDir, bytes, (unsigned) numBytes) != 0) { - Tcl_Panic("Attempt to modify defaultLibraryDir"); - } - return; - } - - /* - * First call from any thread; set up exit handler - */ - - Tcl_CreateExitHandler(FreeDefaultLibraryDir, NULL); - - defaultLibraryDirLength = numBytes; - defaultLibraryDir = ckalloc((unsigned int) numBytes + 1); - memcpy(defaultLibraryDir, bytes, (unsigned int) numBytes + 1); -} - -/* - *--------------------------------------------------------------------------- - * - * GetDefaultLibraryDir -- - * - * Called by TclpSetVariables to retrieve the saved value - * stored by SetDefaultLibraryDir in order to store that value - * in ::tclDefaultLibrary . - * - * Results: - * A pointer to a Tcl_Obj holding the default directory path - * for init.tcl. - * - * Side effects: - * - *--------------------------------------------------------------------------- - */ - -static Tcl_Obj * -GetDefaultLibraryDir() -{ - Tcl_Obj **savedDirectoryPtr = (Tcl_Obj **) - Tcl_GetThreadData(&defaultLibraryDirKey, (int) sizeof(Tcl_Obj *)); - - if (NULL != *savedDirectoryPtr) { - return *savedDirectoryPtr; - } - - if (NULL == defaultLibraryDir) { - /* - * Careful here. This may be bogus, calling TclpInitLibraryPath - * when not in TclpInitLock. - * - * This path is taken by wish because it calls Tcl_CreateInterp - * before it calls Tcl_FindExecutable. - */ - TclpInitLibraryPath(NULL); - if (NULL != *savedDirectoryPtr) { - return *savedDirectoryPtr; - } else { - Tcl_Panic("TclpInitLibraryPath failed to set default library dir"); - } - } - - *savedDirectoryPtr = - Tcl_NewStringObj(defaultLibraryDir, defaultLibraryDirLength); - Tcl_IncrRefCount(*savedDirectoryPtr); - Tcl_CreateThreadExitHandler(FreeThreadDefaultLibraryDir, - (ClientData) savedDirectoryPtr); - return *savedDirectoryPtr; -} +static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib); +static int ToUtf(CONST WCHAR *wSrc, char *dst); /* *--------------------------------------------------------------------------- @@ -304,61 +152,45 @@ TclpInitPlatform() } /* - *--------------------------------------------------------------------------- + *------------------------------------------------------------------------- * * TclpInitLibraryPath -- * - * Initialize the library path at startup. - * - * This call sets the library path to strings in UTF-8. Any - * pre-existing library path information is assumed to have been - * in the native multibyte encoding. - * - * Called at process initialization time. + * This is the fallback routine that sets the library path + * if the application has not set one by the first time + * it is needed. * * Results: - * Return 0, indicating that the UTF is clean. + * None. * * Side effects: - * None. + * Sets the library path to an initial value. * - *--------------------------------------------------------------------------- - */ + *------------------------------------------------------------------------- + */ -int -TclpInitLibraryPath(path) - CONST char *path; /* Potentially dirty UTF string that is */ - /* the path to the executable name. */ +void +TclpInitLibraryPath(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; { #define LIBRARY_SIZE 32 - Tcl_Obj *pathPtr, *objPtr, **objv; - CONST char *str; - Tcl_DString ds; - int objc; + Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; + char *bytes; - Tcl_DStringInit(&ds); pathPtr = Tcl_NewObj(); /* - * Initialize the substrings used when locating an executable. The - * installLib variable computes the path as though the executable - * is installed. + * Initialize the substring used when locating the script library. The + * installLib variable computes the script library path relative to the + * installed DLL. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* - * Look for the library relative to default encoding dir. - */ - - str = Tcl_GetDefaultEncodingDir(); - if ((str != NULL) && (str[0] != '\0')) { - objPtr = Tcl_NewStringObj(str, -1); - Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - } - - /* * Look for the library relative to the TCL_LIBRARY env variable. * If the last dirname in the TCL_LIBRARY path does not match the * last dirname in the installLib variable, use the last dir name @@ -368,17 +200,16 @@ TclpInitLibraryPath(path) AppendEnvironment(pathPtr, installLib); /* - * Look for the library relative to the DLL. Only use the installLib - * because in practice, the DLL is always installed. + * Look for the library in its default location. */ - - AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib); - - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - SetDefaultLibraryDir(Tcl_DuplicateObj(objv[objc-1])); - TclSetLibraryPath(pathPtr); - - return 0; /* 0 indicates that pathPtr is clean (true) utf */ + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&defaultLibraryDir)); + + *encodingPtr = NULL; + bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); + *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); + memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t)(*lengthPtr)+1); + Tcl_DecrRefCount(pathPtr); } /* @@ -481,10 +312,10 @@ AppendEnvironment( /* *--------------------------------------------------------------------------- * - * AppendDllPath -- + * InitializeDefaultLibraryDir -- * - * Append a path onto the path pointer that tries to locate the Tcl - * library relative to the location of the Tcl DLL. + * Locate the Tcl script library default location relative to + * the location of the Tcl DLL. * * Results: * None. @@ -496,22 +327,21 @@ AppendEnvironment( */ static void -AppendDllPath( - Tcl_Obj *pathPtr, - HMODULE hModule, - CONST char *lib) +InitializeDefaultLibraryDir(valuePtr, lengthPtr, encodingPtr) + char **valuePtr; + int *lengthPtr; + Tcl_Encoding *encodingPtr; { + HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char *end, *p; if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { GetModuleFileNameA(hModule, name, MAX_PATH); } else { ToUtf(wName, name); } - if (lib != NULL) { - char *end, *p; - end = strrchr(name, '\\'); *end = '\0'; p = strrchr(name, '\\'); @@ -519,10 +349,12 @@ AppendDllPath( end = p; } *end = '\\'; - strcpy(end + 1, lib); - } TclWinNoBackslash(name); - Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1)); + sprintf(end + 1, "lib/tcl%s", TCL_VERSION); + *lengthPtr = strlen(name); + *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); + *encodingPtr = NULL; + memcpy((VOID *) *valuePtr, (VOID *) name, (size_t) *lengthPtr + 1); } /* @@ -580,11 +412,6 @@ void TclWinEncodingsCleanup() { TclWinResetInterfaceEncodings(); - libraryPathEncodingFixed = 0; - if (binaryEncoding != NULL) { - Tcl_FreeEncoding(binaryEncoding); - binaryEncoding = NULL; - } } /* @@ -614,57 +441,26 @@ TclWinEncodingsCleanup() void TclpSetInitialEncodings() { - CONST char *encoding; - char buf[4 + TCL_INTEGER_SPACE]; - - if (libraryPathEncodingFixed == 0) { - int platformId, useWide; - - platformId = TclWinGetPlatformId(); - useWide = ((platformId == VER_PLATFORM_WIN32_NT) - || (platformId == VER_PLATFORM_WIN32_CE)); - TclWinSetInterfaces(useWide); - - wsprintfA(buf, "cp%d", GetACP()); - Tcl_SetSystemEncoding(NULL, buf); - - if (!useWide) { - Tcl_Obj *pathPtr = TclGetLibraryPath(); - if (pathPtr != NULL) { - int i, objc; - Tcl_Obj **objv; - - objc = 0; - Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv); - for (i = 0; i < objc; i++) { - int length; - char *string; - Tcl_DString ds; - - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_ExternalToUtfDString(NULL, string, length, &ds); - Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - } - } - } + int platformId, useWide; + Tcl_DString encodingName; - libraryPathEncodingFixed = 1; - } else { - wsprintfA(buf, "cp%d", GetACP()); - Tcl_SetSystemEncoding(NULL, buf); - } + platformId = TclWinGetPlatformId(); + useWide = ((platformId == VER_PLATFORM_WIN32_NT) + || (platformId == VER_PLATFORM_WIN32_CE)); + TclWinSetInterfaces(useWide); - /* This is only ever called from the startup thread */ - if (binaryEncoding == NULL) { - /* - * Keep this encoding preloaded. The IO package uses it for - * gets on a binary channel. - */ - encoding = "iso8859-1"; - binaryEncoding = Tcl_GetEncoding(NULL, encoding); - } + Tcl_SetSystemEncoding(NULL, + TclpGetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} + +CONST char * +TclpGetEncodingNameFromEnvironment(bufPtr) + Tcl_DString *bufPtr; +{ + Tcl_DStringInit(bufPtr); + wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); + return Tcl_DStringValue(bufPtr); } /* @@ -699,7 +495,7 @@ TclpSetVariables(interp) DWORD dwUserNameLen = sizeof(szUserName); Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, - GetDefaultLibraryDir(), TCL_GLOBAL_ONLY); + TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); GetVersionExA(&osInfo); diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4266f1a..4b18c02 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.51 2004/11/09 04:07:27 davygrvy Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.52 2004/11/30 19:34:52 dgp Exp $ */ #include "tclWinInt.h" @@ -1211,7 +1211,11 @@ TclpCreateProcess( Tcl_DString pipeDll; Tcl_DStringInit(&pipeDll); Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1); - tclExePtr = Tcl_NewStringObj(TclpFindExecutable(""), -1); + + /* For safety, just in case the app didn't call it first */ + Tcl_FindExecutable(NULL); + + tclExePtr = Tcl_NewStringObj(Tcl_GetNameOfExecutable(), -1); start = Tcl_GetStringFromObj(tclExePtr, &i); for (end = start + (i-1); end > start; end--) { if (*end == '/') { |