Attachment "976520.patch" to
ticket [976520ffff]
added by
dgp
2004-12-01 01:16:54.
Index: generic/tclBasic.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBasic.c,v
retrieving revision 1.135
diff -u -r1.135 tclBasic.c
--- generic/tclBasic.c 13 Nov 2004 00:19:06 -0000 1.135
+++ generic/tclBasic.c 30 Nov 2004 18:15:07 -0000
@@ -183,7 +183,7 @@
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
- TclInitSubsystems(NULL);
+ TclInitSubsystems();
/*
* Panic if someone updated the CallFrame structure without
Index: generic/tclEncoding.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEncoding.c,v
retrieving revision 1.26
diff -u -r1.26 tclEncoding.c
--- generic/tclEncoding.c 12 Nov 2004 23:42:17 -0000 1.26
+++ generic/tclEncoding.c 30 Nov 2004 18:15:07 -0000
@@ -135,12 +135,35 @@
#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 @@
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 @@
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 @@
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 @@
{
Tcl_EncodingType type;
+ if (encodingsInitialized) {
+ return;
+ }
+
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
@@ -296,8 +511,10 @@
type.nullSize = 2;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
-}
+ encodingsInitialized = 1;
+
+}
/*
*----------------------------------------------------------------------
@@ -344,10 +561,15 @@
*
* 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 @@
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_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 @@
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 @@
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);
- }
-
- 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);
+ /* 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);
+ }
+
+ /* 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 @@
* 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 @@
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 @@
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 @@
}
/*
- *----------------------------------------------------------------------
- *
- * 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 @@
}
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;
+ char *bytes;
+ int i, numDirs, numBytes;
+ Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1);
+ Tcl_Obj *searchPath = Tcl_NewObj();
- /*
- * 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().
- */
+ 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;
- 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);
- }
+ 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();
+ Tcl_IncrRefCount(path);
}
-
- return mustCleanUtf;
+ 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);
}
-
Index: generic/tclEvent.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclEvent.c,v
retrieving revision 1.52
diff -u -r1.52 tclEvent.c
--- generic/tclEvent.c 18 Nov 2004 20:15:32 -0000 1.52
+++ generic/tclEvent.c 30 Nov 2004 18:15:08 -0000
@@ -98,17 +98,9 @@
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 @@
/*
*-------------------------------------------------------------------------
- *
- * 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 @@
*/
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 @@
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 @@
}
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();
- }
}
/*
@@ -1017,22 +898,10 @@
*/
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 @@
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) {
/*
Index: generic/tclIO.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIO.c,v
retrieving revision 1.80
diff -u -r1.80 tclIO.c
--- generic/tclIO.c 9 Nov 2004 15:47:26 -0000 1.80
+++ generic/tclIO.c 30 Nov 2004 18:15:08 -0000
@@ -3556,8 +3556,7 @@
/*
* 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) {
Index: generic/tclInt.decls
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.decls,v
retrieving revision 1.82
diff -u -r1.82 tclInt.decls
--- generic/tclInt.decls 27 Oct 2004 17:13:58 -0000 1.82
+++ generic/tclInt.decls 30 Nov 2004 18:15:08 -0000
@@ -841,6 +841,15 @@
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)
+}
##############################################################################
Index: generic/tclInt.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInt.h,v
retrieving revision 1.200
diff -u -r1.200 tclInt.h
--- generic/tclInt.h 17 Nov 2004 17:53:01 -0000 1.200
+++ generic/tclInt.h 30 Nov 2004 18:15:08 -0000
@@ -1688,14 +1688,46 @@
/*
*----------------------------------------------------------------
+ * 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 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 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 @@
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 @@
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,
Index: generic/tclIntDecls.h
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclIntDecls.h,v
retrieving revision 1.73
diff -u -r1.73 tclIntDecls.h
--- generic/tclIntDecls.h 3 Nov 2004 19:13:38 -0000 1.73
+++ generic/tclIntDecls.h 30 Nov 2004 18:15:09 -0000
@@ -1085,6 +1085,23 @@
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 @@
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 @@
#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) */
Index: generic/tclInterp.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclInterp.c,v
retrieving revision 1.52
diff -u -r1.52 tclInterp.c
--- generic/tclInterp.c 22 Nov 2004 21:24:30 -0000 1.52
+++ generic/tclInterp.c 30 Nov 2004 18:15:09 -0000
@@ -17,109 +17,6 @@
#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 @@
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;
}
/*
Index: generic/tclNotify.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclNotify.c,v
retrieving revision 1.15
diff -u -r1.15 tclNotify.c
--- generic/tclNotify.c 15 Jul 2004 21:17:03 -0000 1.15
+++ generic/tclNotify.c 30 Nov 2004 18:15:09 -0000
@@ -81,7 +81,7 @@
* be replaced with a hashtable.
*/
-static ThreadSpecificData *firstNotifierPtr;
+static ThreadSpecificData *firstNotifierPtr = NULL;
TCL_DECLARE_MUTEX(listLock)
/*
@@ -111,15 +111,22 @@
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);
}
Index: generic/tclStubInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclStubInit.c,v
retrieving revision 1.107
diff -u -r1.107 tclStubInit.c
--- generic/tclStubInit.c 13 Nov 2004 00:19:10 -0000 1.107
+++ generic/tclStubInit.c 30 Nov 2004 18:15:09 -0000
@@ -293,6 +293,9 @@
TclpObjStat, /* 206 */
TclpObjAccess, /* 207 */
TclpOpenFileChannel, /* 208 */
+ TclGetEncodingSearchPath, /* 209 */
+ TclSetEncodingSearchPath, /* 210 */
+ TclpGetEncodingNameFromEnvironment, /* 211 */
};
TclIntPlatStubs tclIntPlatStubs = {
Index: generic/tclTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclTest.c,v
retrieving revision 1.85
diff -u -r1.85 tclTest.c
--- generic/tclTest.c 7 Oct 2004 22:01:18 -0000 1.85
+++ generic/tclTest.c 30 Nov 2004 18:15:10 -0000
@@ -1818,9 +1818,9 @@
}
case ENC_PATH: {
if (objc == 2) {
- Tcl_SetObjResult(interp, TclGetLibraryPath());
+ Tcl_SetObjResult(interp, TclGetEncodingSearchPath());
} else {
- TclSetLibraryPath(objv[2]);
+ TclSetEncodingSearchPath(objv[2]);
}
break;
}
Index: generic/tclUtil.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclUtil.c,v
retrieving revision 1.48
diff -u -r1.48 tclUtil.c
--- generic/tclUtil.c 14 Oct 2004 15:06:03 -0000 1.48
+++ generic/tclUtil.c 30 Nov 2004 18:15:10 -0000
@@ -17,17 +17,33 @@
#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 @@
* 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 @@
/*
*----------------------------------------------------------------------
*
+ * 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 @@
* 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 @@
*----------------------------------------------------------------------
*/
+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;
}
+
/*
*----------------------------------------------------------------------
*
Index: tests/encoding.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/encoding.test,v
retrieving revision 1.20
diff -u -r1.20 encoding.test
--- tests/encoding.test 7 May 2004 20:01:23 -0000 1.20
+++ tests/encoding.test 30 Nov 2004 18:15:12 -0000
@@ -95,7 +95,7 @@
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 @@
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]
Index: tests/unixInit.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/unixInit.test,v
retrieving revision 1.43
diff -u -r1.43 unixInit.test
--- tests/unixInit.test 22 Nov 2004 21:24:31 -0000 1.43
+++ tests/unixInit.test 30 Nov 2004 18:15:13 -0000
@@ -113,8 +113,15 @@
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 @@
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.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 @@
}
} -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 @@
{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 @@
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 @@
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 @@
# ../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 @@
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 @@
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 @@
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 @@
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] ]
Index: unix/tclUnixFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixFile.c,v
retrieving revision 1.42
diff -u -r1.42 tclUnixFile.c
--- unix/tclUnixFile.c 7 Oct 2004 14:50:23 -0000 1.42
+++ unix/tclUnixFile.c 30 Nov 2004 18:15:13 -0000
@@ -42,7 +42,7 @@
*---------------------------------------------------------------------------
*/
-char *
+void
TclpFindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
@@ -50,13 +50,13 @@
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 @@
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 @@
#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 @@
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();
}
/*
Index: unix/tclUnixInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixInit.c,v
retrieving revision 1.52
diff -u -r1.52 tclUnixInit.c
--- unix/tclUnixInit.c 22 Nov 2004 22:13:40 -0000 1.52
+++ unix/tclUnixInit.c 30 Nov 2004 18:15:13 -0000
@@ -93,11 +93,6 @@
#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 @@
} 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 @@
*/
(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 @@
*
* 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 @@
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 @@
} else
#endif /* HAVE_CFBUNDLE */
{
+ /* TODO: Pull this value from the TIP 59 table */
str = defaultLibraryDir;
}
if (str[0] != '\0') {
@@ -418,11 +541,13 @@
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 @@
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;
+ Tcl_DString encodingName;
+ Tcl_SetSystemEncoding(NULL,
+ TclpGetEncodingNameFromEnvironment(&encodingName));
+ Tcl_DStringFree(&encodingName);
+}
- /*
- * Use a DString so we can overwrite it in name compatability
- * checks below.
- */
+CONST char *
+TclpGetEncodingNameFromEnvironment(bufPtr)
+ Tcl_DString *bufPtr;
+{
+ CONST char *encoding;
+ int i;
- Tcl_DStringInit(&ds);
- encoding = Tcl_DStringAppend(&ds, nl_langinfo(CODESET), -1);
+ Tcl_DStringInit(bufPtr);
- 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.
- */
+ /*
+ * 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;
- for (i = 0; localeTable[i].lang != NULL; i++) {
- if (strcmp(localeTable[i].lang, encoding) == 0) {
- setSysEncCode = Tcl_SetSystemEncoding(NULL,
- localeTable[i].encoding);
- break;
- }
+ /* 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);
}
/*
Index: unix/tclUnixTest.c
===================================================================
RCS file: /cvsroot/tcl/tcl/unix/tclUnixTest.c,v
retrieving revision 1.18
diff -u -r1.18 tclUnixTest.c
--- unix/tclUnixTest.c 18 Jun 2004 20:38:02 -0000 1.18
+++ unix/tclUnixTest.c 30 Nov 2004 18:15:13 -0000
@@ -444,7 +444,6 @@
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
- char *oldName;
char *oldNativeName;
int oldDone;
@@ -454,24 +453,19 @@
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 @@
* 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 @@
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 @@
* 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 @@
return TCL_ERROR;
}
- if (tclDefaultEncodingDir != NULL) {
- Tcl_AppendResult(interp, tclDefaultEncodingDir, (char *) NULL);
- }
+ Tcl_AppendResult(interp, Tcl_GetDefaultEncodingDir(), (char *) NULL);
return TCL_OK;
}
Index: win/tclWinFile.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinFile.c,v
retrieving revision 1.70
diff -u -r1.70 tclWinFile.c
--- win/tclWinFile.c 2 Nov 2004 12:13:36 -0000 1.70
+++ win/tclWinFile.c 30 Nov 2004 18:15:13 -0000
@@ -691,19 +691,20 @@
*---------------------------------------------------------------------------
*/
-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 @@
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();
}
/*
Index: win/tclWinInit.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinInit.c,v
retrieving revision 1.63
diff -u -r1.63 tclWinInit.c
--- win/tclWinInit.c 24 Nov 2004 21:12:20 -0000 1.63
+++ win/tclWinInit.c 30 Nov 2004 18:15:13 -0000
@@ -92,167 +92,15 @@
"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
- */
-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 *));
-
- 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:
- *
- *---------------------------------------------------------------------------
+ * The default directory in which the init.tcl file is expected to be found.
*/
+static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir;
+static ProcessGlobalValue defaultLibraryDir =
+ {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL};
-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 @@
}
/*
- *---------------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*
* 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 @@
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.
*/
+ Tcl_ListObjAppendElement(NULL, pathPtr,
+ TclGetProcessGlobalValue(&defaultLibraryDir));
- 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 */
+ *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 @@
/*
*---------------------------------------------------------------------------
*
- * 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 @@
*/
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 @@
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 @@
TclWinEncodingsCleanup()
{
TclWinResetInterfaceEncodings();
- libraryPathEncodingFixed = 0;
- if (binaryEncoding != NULL) {
- Tcl_FreeEncoding(binaryEncoding);
- binaryEncoding = NULL;
- }
}
/*
@@ -614,57 +441,26 @@
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);
- }
-
- /* 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);
- }
+ platformId = TclWinGetPlatformId();
+ useWide = ((platformId == VER_PLATFORM_WIN32_NT)
+ || (platformId == VER_PLATFORM_WIN32_CE));
+ TclWinSetInterfaces(useWide);
+
+ 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 @@
DWORD dwUserNameLen = sizeof(szUserName);
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
- GetDefaultLibraryDir(), TCL_GLOBAL_ONLY);
+ TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osInfo);
Index: win/tclWinPipe.c
===================================================================
RCS file: /cvsroot/tcl/tcl/win/tclWinPipe.c,v
retrieving revision 1.51
diff -u -r1.51 tclWinPipe.c
--- win/tclWinPipe.c 9 Nov 2004 04:07:27 -0000 1.51
+++ win/tclWinPipe.c 30 Nov 2004 18:15:13 -0000
@@ -1211,7 +1211,11 @@
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 == '/') {
