summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c4
-rw-r--r--generic/tclEncoding.c672
-rw-r--r--generic/tclEvent.c147
-rw-r--r--generic/tclIO.c5
-rw-r--r--generic/tclInt.decls11
-rw-r--r--generic/tclInt.h49
-rw-r--r--generic/tclIntDecls.h34
-rw-r--r--generic/tclInterp.c277
-rw-r--r--generic/tclNotify.c25
-rw-r--r--generic/tclStubInit.c5
-rw-r--r--generic/tclTest.c6
-rw-r--r--generic/tclUtil.c330
12 files changed, 1006 insertions, 559 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a37dff5..d4c9382 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.135 2004/11/13 00:19:06 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.136 2004/11/30 19:34:46 dgp Exp $
*/
#include "tclInt.h"
@@ -183,7 +183,7 @@ Tcl_CreateInterp()
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
- TclInitSubsystems(NULL);
+ TclInitSubsystems();
/*
* Panic if someone updated the CallFrame structure without
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index b24bb0e..c3f53c3 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEncoding.c,v 1.26 2004/11/12 23:42:17 hobbs Exp $
+ * RCS: @(#) $Id: tclEncoding.c,v 1.27 2004/11/30 19:34:47 dgp Exp $
*/
#include "tclInt.h"
@@ -135,12 +135,35 @@ typedef struct EscapeEncodingData {
#define ENCODING_ESCAPE 3
/*
- * Initialize the default encoding directory. If this variable contains
- * a non NULL value, it will be the first path used to locate the
- * system encoding files.
+ * A list of directories in which Tcl should look for *.enc files.
+ * This list is shared by all threads. Access is governed by a
+ * mutex lock.
*/
-char *tclDefaultEncodingDir = NULL;
+static TclInitProcessGlobalValueProc InitializeEncodingSearchPath;
+static ProcessGlobalValue encodingSearchPath =
+ {0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL};
+
+/*
+ * A map from encoding names to the directories in which their data
+ * files have been seen. The string value of the map is shared by all
+ * threads. Access to the shared string is governed by a mutex lock.
+ */
+
+static TclInitProcessGlobalValueProc InitializeEncodingFileMap;
+static ProcessGlobalValue encodingFileMap =
+ {0, 0, NULL, NULL, InitializeEncodingFileMap, NULL, NULL};
+
+/*
+ * A list of directories making up the "library path". Historically
+ * this search path has served many uses, but the only one remaining
+ * is a base for the encodingSearchPath above. If the application
+ * does not explicitly set the encodingSearchPath, then it will be
+ * initialized by appending /encoding to each directory in this
+ * "libraryPath".
+ */
+static ProcessGlobalValue libraryPath =
+ {0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL};
static int encodingsInitialized = 0;
@@ -188,6 +211,7 @@ static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
+static void FillEncodingFileMap ();
static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding));
static Encoding * GetTableEncoding _ANSI_ARGS_((
EscapeEncodingData *dataPtr, int state));
@@ -197,8 +221,7 @@ static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name,
int type, Tcl_Channel chan));
static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name,
Tcl_Channel chan));
-static Tcl_Channel OpenEncodingFile _ANSI_ARGS_((CONST char *dir,
- CONST char *name));
+static Tcl_Obj * MakeFileMap ();
static void TableFreeProc _ANSI_ARGS_((ClientData clientData));
static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
@@ -236,10 +259,198 @@ static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
-static int FindEncodings();
/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetEncodingSearchPath --
+ *
+ * Keeps the per-thread copy of the encoding search path current
+ * with changes to the global copy.
+ *
+ * Results:
+ * Returns a "list" (Tcl_Obj *) that contains the encoding
+ * search path.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetEncodingSearchPath() {
+ return TclGetProcessGlobalValue(&encodingSearchPath);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetEncodingSearchPath --
+ *
+ * Keeps the per-thread copy of the encoding search path current
+ * with changes to the global copy.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSetEncodingSearchPath(searchPath)
+ Tcl_Obj *searchPath;
+{
+ int dummy;
+
+ if (TCL_ERROR == Tcl_ListObjLength(NULL, searchPath, &dummy)) {
+ return TCL_ERROR;
+ }
+ TclSetProcessGlobalValue(&encodingSearchPath, searchPath);
+ FillEncodingFileMap();
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetLibraryPath --
+ *
+ * Keeps the per-thread copy of the library path current
+ * with changes to the global copy.
+ *
+ * Results:
+ * Returns a "list" (Tcl_Obj *) that contains the library path.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetLibraryPath() {
+ return TclGetProcessGlobalValue(&libraryPath);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetLibraryPath --
+ *
+ * Keeps the per-thread copy of the library path current
+ * with changes to the global copy.
+ *
+ * NOTE: this routine returns void, so there's no way to
+ * report the error that searchPath is not a valid list.
+ * In that case, this routine will silently do nothing.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetLibraryPath(path)
+ Tcl_Obj *path;
+{
+ int dummy;
+
+ if (TCL_ERROR == Tcl_ListObjLength(NULL, path, &dummy)) {
+ return;
+ }
+ TclSetProcessGlobalValue(&libraryPath, path);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * MakeFileMap --
+ *
+ * Scan the directories on the encoding search path, find the
+ * *.enc files, and store the found pathnames in a map associated
+ * with the encoding name.
+ *
+ * In particular, if $dir is on the encoding search path, and the
+ * file $dir/foo.enc is found, then store a "foo" -> $dir entry
+ * in the map. Later, any need for the "foo" encoding will quickly
+ * be able to construct the $dir/foo.enc pathname for reading the
+ * encoding data.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Entries are added to the encoding file map.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+MakeFileMap()
+{
+ int i, numDirs = 0;
+ Tcl_Obj *map, *searchPath;
+
+ searchPath = TclGetEncodingSearchPath();
+ Tcl_IncrRefCount(searchPath);
+ Tcl_ListObjLength(NULL, searchPath, &numDirs);
+ map = Tcl_NewDictObj();
+ Tcl_IncrRefCount(map);
+ for (i = numDirs-1; i >= 0; i--) {
+ /*
+ * Iterate backwards through the search path so as we
+ * overwrite entries found, we favor files earlier on
+ * the search path.
+ */
+ int j, numFiles;
+ Tcl_Obj *directory, *matchFileList = Tcl_NewObj();
+ Tcl_Obj **filev;
+ Tcl_GlobTypeData readableFiles =
+ {TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL};
+
+ Tcl_ListObjIndex(NULL, searchPath, i, &directory);
+ Tcl_IncrRefCount(directory);
+ Tcl_IncrRefCount(matchFileList);
+ Tcl_FSMatchInDirectory(NULL, matchFileList,
+ directory, "*.enc", &readableFiles);
+
+ Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev);
+ for (j=0; j<numFiles; j++) {
+ Tcl_Obj *encodingName, *file;
+
+ file = TclPathPart(NULL, filev[j], TCL_PATH_TAIL);
+ Tcl_IncrRefCount(file);
+ encodingName = TclPathPart(NULL, file, TCL_PATH_ROOT);
+ Tcl_IncrRefCount(encodingName);
+ Tcl_DictObjPut(NULL, map, encodingName, directory);
+ }
+ Tcl_DecrRefCount(matchFileList);
+ Tcl_DecrRefCount(directory);
+ }
+ Tcl_DecrRefCount(searchPath);
+ return map;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * FillEncodingFileMap --
+ *
+ * Called to bring the encoding file map in sync with the current
+ * value of the encoding search path.
+ *
+ * TODO: Check the callers of this routine to see if it's called
+ * too frequently.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Entries are added to the encoding file map.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+FillEncodingFileMap()
+{
+ Tcl_Obj *map = MakeFileMap();
+ TclSetProcessGlobalValue(&encodingFileMap, map);
+ Tcl_DecrRefCount(map);
+}
+
+/*
*---------------------------------------------------------------------------
*
* TclInitEncodingSubsystem --
@@ -261,6 +472,10 @@ TclInitEncodingSubsystem()
{
Tcl_EncodingType type;
+ if (encodingsInitialized) {
+ return;
+ }
+
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
@@ -296,8 +511,10 @@ TclInitEncodingSubsystem()
type.nullSize = 2;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
-}
+ encodingsInitialized = 1;
+
+}
/*
*----------------------------------------------------------------------
@@ -344,10 +561,15 @@ TclFinalizeEncodingSubsystem()
*
* Tcl_GetDefaultEncodingDir --
*
+ * Legacy public interface to retrieve first directory in the
+ * encoding searchPath.
*
* Results:
+ * The directory pathname, as a string, or NULL for an empty
+ * encoding search path.
*
* Side effects:
+ * None.
*
*-------------------------------------------------------------------------
*/
@@ -355,7 +577,16 @@ TclFinalizeEncodingSubsystem()
CONST char *
Tcl_GetDefaultEncodingDir()
{
- return tclDefaultEncodingDir;
+ int numDirs;
+ Tcl_Obj *first, *searchPath = TclGetEncodingSearchPath();
+
+ Tcl_ListObjLength(NULL, searchPath, &numDirs);
+ if (numDirs == 0) {
+ return NULL;
+ }
+ Tcl_ListObjIndex(NULL, searchPath, 0, &first);
+
+ return Tcl_GetString(first);
}
/*
@@ -363,10 +594,14 @@ Tcl_GetDefaultEncodingDir()
*
* Tcl_SetDefaultEncodingDir --
*
+ * Legacy public interface to set the first directory in the
+ * encoding search path.
*
* Results:
+ * None.
*
* Side effects:
+ * Modifies the encoding search path.
*
*-------------------------------------------------------------------------
*/
@@ -375,8 +610,12 @@ void
Tcl_SetDefaultEncodingDir(path)
CONST char *path;
{
- tclDefaultEncodingDir = (char *)ckalloc((unsigned) strlen(path) + 1);
- strcpy(tclDefaultEncodingDir, path);
+ Tcl_Obj *searchPath = TclGetEncodingSearchPath();
+ Tcl_Obj *directory = Tcl_NewStringObj(path, -1);
+
+ searchPath = Tcl_DuplicateObj(searchPath);
+ Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
+ TclSetEncodingSearchPath(searchPath);
}
/*
@@ -551,95 +790,42 @@ void
Tcl_GetEncodingNames(interp)
Tcl_Interp *interp; /* Interp to hold result. */
{
+ Tcl_HashTable table;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
- Tcl_Obj *pathPtr, *resultPtr;
- int dummy;
+ Tcl_Obj *map, *name, *result = Tcl_NewObj();
+ Tcl_DictSearch mapSearch;
+ int dummy, done = 0;
- Tcl_HashTable table;
+ Tcl_InitObjHashTable(&table);
+ /* Copy encoding names from loaded encoding table to table */
Tcl_MutexLock(&encodingMutex);
- Tcl_InitHashTable(&table, TCL_STRING_KEYS);
- hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
- while (hPtr != NULL) {
- Encoding *encodingPtr;
-
- encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
- Tcl_CreateHashEntry(&table, encodingPtr->name, &dummy);
- hPtr = Tcl_NextHashEntry(&search);
+ for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ Encoding *encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr);
+ Tcl_CreateHashEntry(&table,
+ (char *) Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
}
Tcl_MutexUnlock(&encodingMutex);
- pathPtr = TclGetLibraryPath();
- if (pathPtr != NULL) {
- int i, objc;
- Tcl_Obj **objv;
- char globArgString[10];
- Tcl_Obj* encodingObj = Tcl_NewStringObj("encoding",-1);
- Tcl_IncrRefCount(encodingObj);
-
- objc = 0;
- Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ FillEncodingFileMap();
+ map = TclGetProcessGlobalValue(&encodingFileMap);
- for (i = 0; i < objc; i++) {
- Tcl_Obj *searchIn;
-
- /*
- * Construct the path from the element of pathPtr,
- * joined with 'encoding'.
- */
- searchIn = Tcl_FSJoinToPath(objv[i],1,&encodingObj);
- Tcl_IncrRefCount(searchIn);
- Tcl_ResetResult(interp);
-
- /*
- * TclGlob() changes the contents of globArgString, which causes
- * a segfault if we pass in a pointer to non-writeable memory.
- * TclGlob() puts its results directly into interp.
- */
-
- strcpy(globArgString, "*.enc");
- /*
- * The GLOBMODE_TAILS flag returns just the tail of each file
- * which is the encoding name with a .enc extension
- */
- if ((TclGlob(interp, globArgString, searchIn,
- TCL_GLOBMODE_TAILS, NULL) == TCL_OK)) {
- int objc2 = 0;
- Tcl_Obj **objv2;
- int j;
-
- Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), &objc2,
- &objv2);
-
- for (j = 0; j < objc2; j++) {
- int length;
- char *string;
- string = Tcl_GetStringFromObj(objv2[j], &length);
- length -= 4;
- if (length > 0) {
- string[length] = '\0';
- Tcl_CreateHashEntry(&table, string, &dummy);
- string[length] = '.';
- }
- }
- }
- Tcl_DecrRefCount(searchIn);
- }
- Tcl_DecrRefCount(encodingObj);
+ /* Copy encoding names from encoding file map to table */
+ Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done);
+ for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) {
+ Tcl_CreateHashEntry(&table, (char *) name, &dummy);
}
- resultPtr = Tcl_NewObj();
- hPtr = Tcl_FirstHashEntry(&table, &search);
- while (hPtr != NULL) {
- Tcl_Obj *strPtr;
-
- strPtr = Tcl_NewStringObj(Tcl_GetHashKey(&table, hPtr), -1);
- Tcl_ListObjAppendElement(NULL, resultPtr, strPtr);
- hPtr = Tcl_NextHashEntry(&search);
+ /* Pull all encoding names from table into the result list */
+ for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_ListObjAppendElement(NULL, result,
+ (Tcl_Obj *) Tcl_GetHashKey(&table, hPtr));
}
+ Tcl_SetObjResult(interp, result);
Tcl_DeleteHashTable(&table);
- Tcl_SetObjResult(interp, resultPtr);
}
/*
@@ -1105,9 +1291,9 @@ Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst,
* None.
*
* Side effects:
- * The variable tclExecutableName gets filled in with the file
+ * The variable tclNativeExecutableName gets filled in with the file
* name for the application, if we figured it out. If we couldn't
- * figure it out, tclExecutableName is set to NULL.
+ * figure it out, tclNativeExecutableName is set to NULL.
*
*---------------------------------------------------------------------------
*/
@@ -1117,59 +1303,9 @@ Tcl_FindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
{
- int mustCleanUtf;
- CONST char *name;
- Tcl_DString buffer, nameString;
-
- TclInitSubsystems(argv0);
-
- if (argv0 == NULL) {
- goto done;
- }
- if (tclExecutableName != NULL) {
- ckfree(tclExecutableName);
- tclExecutableName = NULL;
- }
- if ((name = TclpFindExecutable(argv0)) == NULL) {
- goto done;
- }
-
- /*
- * The value returned from TclpNameOfExecutable is a UTF string that
- * is possibly dirty depending on when it was initialized.
- * FindEncodings will indicate whether we must "clean" the UTF (as
- * reported by the underlying system). To assure that the UTF string
- * is a properly encoded native string for this system, convert the
- * UTF string to the default native encoding before the default
- * encoding is initialized. Then, convert it back to UTF after the
- * system encoding is loaded.
- */
-
- Tcl_UtfToExternalDString(NULL, name, -1, &buffer);
- mustCleanUtf = FindEncodings();
-
- /*
- * Now it is OK to convert the native string back to UTF and set
- * the value of the tclExecutableName.
- */
-
- if (mustCleanUtf) {
- Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1,
- &nameString);
- tclExecutableName = (char *)
- ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
- strcpy(tclExecutableName, Tcl_DStringValue(&nameString));
-
- Tcl_DStringFree(&nameString);
- } else {
- tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1));
- strcpy(tclExecutableName, name);
- }
- Tcl_DStringFree(&buffer);
- return;
-
- done:
- (void) FindEncodings();
+ TclInitSubsystems();
+ TclpSetInitialEncodings();
+ TclpFindExecutable(argv0);
}
/*
@@ -1198,28 +1334,42 @@ LoadEncodingFile(interp, name)
CONST char *name; /* The name of the encoding file on disk
* and also the name for new encoding. */
{
- int objc, i, ch;
- Tcl_Obj **objv;
- Tcl_Obj *pathPtr;
Tcl_Channel chan;
Tcl_Encoding encoding;
+ Tcl_Obj *map, *path, *directory = NULL;
+ Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1);
+ int ch, scanned = 0;
- pathPtr = TclGetLibraryPath();
- if (pathPtr == NULL) {
- goto unknown;
- }
- objc = 0;
- Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- chan = NULL;
- for (i = 0; i < objc; i++) {
- chan = OpenEncodingFile(Tcl_GetString(objv[i]), name);
- if (chan != NULL) {
+ Tcl_IncrRefCount(nameObj);
+ while (1) {
+ map = TclGetProcessGlobalValue(&encodingFileMap);
+ Tcl_DictObjGet(NULL, map, nameObj, &directory);
+ if (scanned || (NULL != directory)) {
break;
}
+scan:
+ FillEncodingFileMap();
+ scanned = 1;
+ }
+ if (NULL == directory) {
+ Tcl_DecrRefCount(nameObj);
+ goto unknown;
}
- if (chan == NULL) {
+ /* Construct $directory/$encoding.enc path name */
+ Tcl_IncrRefCount(directory);
+ Tcl_AppendToObj(nameObj, ".enc", -1);
+ path = Tcl_FSJoinToPath(directory, 1, &nameObj);
+ Tcl_DecrRefCount(directory);
+ Tcl_IncrRefCount(path);
+ chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
+ Tcl_DecrRefCount(path);
+
+ if (NULL == chan) {
+ if (!scanned) {
+ goto scan;
+ }
goto unknown;
}
@@ -1270,53 +1420,6 @@ LoadEncodingFile(interp, name)
}
/*
- *----------------------------------------------------------------------
- *
- * OpenEncodingFile --
- *
- * Look for the file encoding/<name>.enc in the specified
- * directory.
- *
- * Results:
- * Returns an open file channel if the file exists.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Channel
-OpenEncodingFile(dir, name)
- CONST char *dir;
- CONST char *name;
-
-{
- CONST char *argv[3];
- Tcl_DString pathString;
- CONST char *path;
- Tcl_Channel chan;
- Tcl_Obj *pathPtr;
-
- argv[0] = dir;
- argv[1] = "encoding";
- argv[2] = name;
-
- Tcl_DStringInit(&pathString);
- Tcl_JoinPath(3, argv, &pathString);
- path = Tcl_DStringAppend(&pathString, ".enc", -1);
- pathPtr = Tcl_NewStringObj(path,-1);
-
- Tcl_IncrRefCount(pathPtr);
- chan = Tcl_FSOpenFileChannel(NULL, pathPtr, "r", 0);
- Tcl_DecrRefCount(pathPtr);
-
- Tcl_DStringFree(&pathString);
-
- return chan;
-}
-
-/*
*-------------------------------------------------------------------------
*
* LoadTableEncoding --
@@ -2932,91 +3035,108 @@ unilen(src)
}
return (char *) p - src;
}
-
/*
*-------------------------------------------------------------------------
*
- * FindEncodings --
+ * InitializeEncodingSearchPath --
*
- * Find and load the encoding file for this operating system.
- * Before this is called, Tcl makes assumptions about the
- * native string representation, but the true encoding is not
- * assured.
+ * This is the fallback routine that sets the default value
+ * of the encoding search path if the application has not set
+ * one via a call to TclSetEncodingSearchPath() by the first
+ * time the search path is needed to load encoding data.
+ *
+ * The default encoding search path is produced by taking each
+ * directory in the library path, appending a subdirectory
+ * named "encoding", and if the resulting directory exists,
+ * adding it to the encoding search path.
*
* Results:
- * Return result of TclpInitLibraryPath, which reports whether the
- * path is clean (0) or dirty (1) UTF.
+ * None.
*
* Side effects:
- * Varied, see the respective initialization routines.
+ * Sets the encoding search path to an initial value.
*
*-------------------------------------------------------------------------
*/
-static int
-FindEncodings()
+void
+InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr)
+ char **valuePtr;
+ int *lengthPtr;
+ Tcl_Encoding *encodingPtr;
{
- int mustCleanUtf = 0;
-
- if (encodingsInitialized == 0) {
- /*
- * Double check inside the mutex. There may be calls
- * back into this routine from some of the procedures below.
- */
-
- TclpInitLock();
- if (encodingsInitialized == 0) {
- Tcl_Obj *pathPtr;
- Tcl_DString libPath, buffer;
-
- /*
- * Have to set this bit here to avoid deadlock with the
- * routines below us that call into TclInitSubsystems.
- */
-
- encodingsInitialized = 1;
-
- /*
- * NOTE: we can safely make direct use of tclNativeExecutableName
- * because we know all our callers ( Tcl_FindExecutable() is the
- * only one) have already called TclpFindExecutable().
- */
-
- mustCleanUtf = TclpInitLibraryPath(tclNativeExecutableName);
-
- /*
- * The library path was set in the TclpInitLibraryPath routine.
- * The string set is a dirty UTF string. To preserve the value
- * convert the UTF string back to native before setting the new
- * default encoding.
- */
-
- pathPtr = TclGetLibraryPath();
- if ((pathPtr != NULL) && mustCleanUtf) {
- Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1,
- &libPath);
- }
-
- TclpSetInitialEncodings();
-
- /*
- * Now convert the native string back to UTF.
- */
-
- if ((pathPtr != NULL) && mustCleanUtf) {
- Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1,
- &buffer);
- pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1);
- TclSetLibraryPath(pathPtr);
-
- Tcl_DStringFree(&libPath);
- Tcl_DStringFree(&buffer);
- }
+ char *bytes;
+ int i, numDirs, numBytes;
+ Tcl_Obj *libPath, *encodingObj = Tcl_NewStringObj("encoding", -1);
+ Tcl_Obj *searchPath = Tcl_NewObj();
+
+ Tcl_IncrRefCount(encodingObj);
+ Tcl_IncrRefCount(searchPath);
+ libPath = TclGetLibraryPath();
+ Tcl_IncrRefCount(libPath);
+ Tcl_ListObjLength(NULL, libPath, &numDirs);
+ for (i = 0; i < numDirs; i++) {
+ Tcl_Obj *directory, *path;
+ Tcl_StatBuf stat;
+
+ Tcl_ListObjIndex(NULL, libPath, i, &directory);
+ path = Tcl_FSJoinToPath(directory, 1, &encodingObj);
+ Tcl_IncrRefCount(path);
+ if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) {
+ Tcl_ListObjAppendElement(NULL, searchPath, path);
}
- TclpInitUnlock();
- }
-
- return mustCleanUtf;
+ Tcl_IncrRefCount(path);
+ }
+ Tcl_DecrRefCount(libPath);
+ Tcl_DecrRefCount(encodingObj);
+ *encodingPtr = libraryPath.encoding;
+ if (*encodingPtr) {
+ ((Encoding *)(*encodingPtr))->refCount++;
+ }
+ bytes = Tcl_GetStringFromObj(searchPath, &numBytes);
+ *lengthPtr = numBytes;
+ *valuePtr = ckalloc((unsigned int) numBytes + 1);
+ memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
+ Tcl_DecrRefCount(searchPath);
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * InitializeEncodingFileMap --
+ *
+ * This is the fallback routine that fills the encoding data
+ * file map if the application has not set up an encoding
+ * search path by the first time the file map is needed to
+ * load encoding data.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Fills the encoding data file map.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+void
+InitializeEncodingFileMap(valuePtr, lengthPtr, encodingPtr)
+ char **valuePtr;
+ int *lengthPtr;
+ Tcl_Encoding *encodingPtr;
+{
+ char *bytes;
+ int numBytes;
+ Tcl_Obj *map = MakeFileMap();
+
+ *encodingPtr = encodingSearchPath.encoding;
+ if (*encodingPtr) {
+ ((Encoding *)(*encodingPtr))->refCount++;
+ }
+ bytes = Tcl_GetStringFromObj(map, &numBytes);
+ *lengthPtr = numBytes;
+ *valuePtr = ckalloc((unsigned int) numBytes + 1);
+ memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1);
+ Tcl_DecrRefCount(map);
}
-
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 57ec9b7..f180f26 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclEvent.c,v 1.52 2004/11/18 20:15:32 dgp Exp $
+ * RCS: @(#) $Id: tclEvent.c,v 1.53 2004/11/30 19:34:47 dgp Exp $
*/
#include "tclInt.h"
@@ -98,17 +98,9 @@ typedef struct ThreadSpecificData {
int inExit; /* True when this thread is exiting. This
* is used as a hack to decide to close
* the standard channels. */
- Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
-/*
- * Common string for the library path for sharing across threads.
- * This is ckalloc'd and cleared in Tcl_Finalize.
- */
-static char *tclLibraryPathStr = NULL;
-
-
#ifdef TCL_THREADS
typedef struct {
@@ -747,92 +739,6 @@ Tcl_Exit(status)
/*
*-------------------------------------------------------------------------
- *
- * TclSetLibraryPath --
- *
- * Set the path that will be used for searching for init.tcl and
- * encodings when an interp is being created.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Changing the library path will affect what directories are
- * examined when looking for encodings for all interps from that
- * point forward.
- *
- * The refcount of the new library path is incremented and the
- * refcount of the old path is decremented.
- *
- *-------------------------------------------------------------------------
- */
-
-void
-TclSetLibraryPath(pathPtr)
- Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
- * the new library path. */
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- const char *toDupe;
- int size;
-
- if (pathPtr != NULL) {
- Tcl_IncrRefCount(pathPtr);
- }
- if (tsdPtr->tclLibraryPath != NULL) {
- Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
- }
- tsdPtr->tclLibraryPath = pathPtr;
-
- /*
- * No mutex locking is needed here as up the stack we're within
- * TclpInitLock().
- */
- if (tclLibraryPathStr != NULL) {
- ckfree(tclLibraryPathStr);
- }
- toDupe = Tcl_GetStringFromObj(pathPtr, &size);
- tclLibraryPathStr = ckalloc((unsigned)size+1);
- memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1);
-}
-
-/*
- *-------------------------------------------------------------------------
- *
- * TclGetLibraryPath --
- *
- * Return a Tcl list object whose elements are the library path.
- * The caller should not modify the contents of the returned object.
- *
- * Results:
- * As above.
- *
- * Side effects:
- * None.
- *
- *-------------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclGetLibraryPath()
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- if (tsdPtr->tclLibraryPath == NULL) {
- /*
- * Grab the shared string and place it into a new thread specific
- * Tcl_Obj.
- */
- tsdPtr->tclLibraryPath = Tcl_NewStringObj(tclLibraryPathStr, -1);
-
- /* take ownership */
- Tcl_IncrRefCount(tsdPtr->tclLibraryPath);
- }
- return tsdPtr->tclLibraryPath;
-}
-
-/*
- *-------------------------------------------------------------------------
*
* TclInitSubsystems --
*
@@ -858,25 +764,12 @@ TclGetLibraryPath()
*/
void
-TclInitSubsystems(argv0)
- CONST char *argv0; /* Name of executable from argv[0] to main()
- * in native multi-byte encoding. */
+TclInitSubsystems()
{
- ThreadSpecificData *tsdPtr;
-
if (inFinalize != 0) {
Tcl_Panic("TclInitSubsystems called while finalizing");
}
- /*
- * Grab the thread local storage pointer before doing anything because
- * the initialization routines will be registering exit handlers.
- * We use this pointer to detect if this is the first time this
- * thread has created an interpreter.
- */
-
- tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
-
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls
@@ -892,8 +785,6 @@ TclInitSubsystems(argv0)
subsystemsInitialized = 1;
- tclExecutableName = NULL;
-
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
@@ -914,17 +805,7 @@ TclInitSubsystems(argv0)
}
TclpInitUnlock();
}
-
- if (tsdPtr == NULL) {
- /*
- * First time this thread has created an interpreter.
- * We fetch the key again just in case no exit handlers were
- * registered by this point.
- */
-
- (void) TCL_TSD_INIT(&dataKey);
- TclInitNotifier();
- }
+ TclInitNotifier();
}
/*
@@ -1017,22 +898,10 @@ Tcl_Finalize()
*/
TclFinalizeEncodingSubsystem();
- if (tclExecutableName != NULL) {
- ckfree(tclExecutableName);
- tclExecutableName = NULL;
- }
if (tclNativeExecutableName != NULL) {
ckfree(tclNativeExecutableName);
tclNativeExecutableName = NULL;
}
- if (tclDefaultEncodingDir != NULL) {
- ckfree(tclDefaultEncodingDir);
- tclDefaultEncodingDir = NULL;
- }
- if (tclLibraryPathStr != NULL) {
- ckfree(tclLibraryPathStr);
- tclLibraryPathStr = NULL;
- }
Tcl_SetPanicProc(NULL);
@@ -1113,16 +982,6 @@ Tcl_FinalizeThread()
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
- /*
- * Clean up the library path now, before we invalidate thread-local
- * storage or calling thread exit handlers.
- */
-
- if (tsdPtr->tclLibraryPath != NULL) {
- Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
- tsdPtr->tclLibraryPath = NULL;
- }
-
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index b41a7b6..bb6c438 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIO.c,v 1.80 2004/11/09 15:47:26 dkf Exp $
+ * RCS: @(#) $Id: tclIO.c,v 1.81 2004/11/30 19:34:47 dgp Exp $
*/
#include "tclInt.h"
@@ -3556,8 +3556,7 @@ Tcl_GetsObj(chan, objPtr)
/*
* If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't
- * produce ByteArray objects. To avoid circularity problems,
- * "iso8859-1" is builtin to Tcl.
+ * produce ByteArray objects.
*/
if (encoding == NULL) {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 3b5dc5d..d6cdd1f 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.82 2004/10/27 17:13:58 davygrvy Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.83 2004/11/30 19:34:48 dgp Exp $
library tcl
@@ -841,6 +841,15 @@ declare 208 generic {
Tcl_Channel TclpOpenFileChannel (Tcl_Interp *interp,
Tcl_Obj *pathPtr, int mode, int permissions)
}
+declare 209 generic {
+ Tcl_Obj * TclGetEncodingSearchPath(void)
+}
+declare 210 generic {
+ int TclSetEncodingSearchPath(Tcl_Obj *searchPath)
+}
+declare 211 generic {
+ CONST char * TclpGetEncodingNameFromEnvironment(Tcl_DString *bufPtr)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a4ac12e..4510239 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.200 2004/11/17 17:53:01 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.201 2004/11/30 19:34:48 dgp Exp $
*/
#ifndef _TCLINT
@@ -1688,14 +1688,46 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
/*
*----------------------------------------------------------------
+ * Data structures for process-global values.
+ *----------------------------------------------------------------
+ */
+
+typedef void (TclInitProcessGlobalValueProc) _ANSI_ARGS_((char **valuePtr,
+ int *lengthPtr, Tcl_Encoding *encodingPtr));
+
+/*
+ * A ProcessGlobalValue struct exists for each internal value in
+ * Tcl that is to be shared among several threads. Each thread
+ * sees a (Tcl_Obj) copy of the value, and the master is kept as
+ * a counted string, with epoch and mutex control. Each ProcessGlobalValue
+ * struct should be a static variable in some file.
+ */
+typedef struct ProcessGlobalValue {
+ int epoch; /* Epoch counter to detect changes
+ * in the master value */
+ int numBytes; /* Length of the master string */
+ char *value; /* The master string value */
+ Tcl_Encoding encoding; /* system encoding when master string
+ * was initialized */
+ TclInitProcessGlobalValueProc *proc;
+ /* A procedure to initialize the
+ * master string copy when a "get"
+ * request comes in before any
+ * "set" request has been received. */
+ Tcl_Mutex mutex; /* Enforce orderly access from
+ * multiple threads */
+ Tcl_ThreadDataKey key; /* Key for per-thread data holding
+ * the (Tcl_Obj) copy for each thread */
+} ProcessGlobalValue;
+
+/*
+ *----------------------------------------------------------------
* Variables shared among Tcl modules but not used by the outside world.
*----------------------------------------------------------------
*/
-MODULE_SCOPE char * tclExecutableName;
MODULE_SCOPE char * tclNativeExecutableName;
MODULE_SCOPE int tclFindExecutableSearchDone;
-MODULE_SCOPE char * tclDefaultEncodingDir;
MODULE_SCOPE char * tclMemDumpFileName;
MODULE_SCOPE TclPlatformType tclPlatform;
MODULE_SCOPE Tcl_NotifierProcs tclOriginalNotifier;
@@ -1802,6 +1834,8 @@ MODULE_SCOPE void TclFinalizeSynchronization _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeLock _ANSI_ARGS_((void));
MODULE_SCOPE void TclFinalizeThreadData _ANSI_ARGS_((void));
MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp));
+MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue _ANSI_ARGS_ ((
+ ProcessGlobalValue *pgvPtr));
MODULE_SCOPE int TclGlob _ANSI_ARGS_((Tcl_Interp *interp,
char *pattern, Tcl_Obj *unquotedPrefix,
int globFlags, Tcl_GlobTypeData* types));
@@ -1815,7 +1849,7 @@ MODULE_SCOPE void TclInitLimitSupport _ANSI_ARGS_((Tcl_Interp *interp));
MODULE_SCOPE void TclInitNamespaceSubsystem _ANSI_ARGS_((void));
MODULE_SCOPE void TclInitNotifier _ANSI_ARGS_((void));
MODULE_SCOPE void TclInitObjSubsystem _ANSI_ARGS_((void));
-MODULE_SCOPE void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0));
+MODULE_SCOPE void TclInitSubsystems ();
MODULE_SCOPE int TclIsLocalScalar _ANSI_ARGS_((CONST char *src,
int len));
MODULE_SCOPE int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id,
@@ -1879,11 +1913,12 @@ MODULE_SCOPE int TclpThreadCreate _ANSI_ARGS_((
int stackSize, int flags));
MODULE_SCOPE void TclpFinalizeThreadDataKey _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
-MODULE_SCOPE char * TclpFindExecutable _ANSI_ARGS_((
+MODULE_SCOPE void TclpFindExecutable _ANSI_ARGS_((
CONST char *argv0));
MODULE_SCOPE int TclpFindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
-MODULE_SCOPE int TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
+MODULE_SCOPE void TclpInitLibraryPath _ANSI_ARGS_((char **valuePtr,
+ int *lengthPtr, Tcl_Encoding *encodingPtr));
MODULE_SCOPE void TclpInitLock _ANSI_ARGS_((void));
MODULE_SCOPE void TclpInitPlatform _ANSI_ARGS_((void));
MODULE_SCOPE void TclpInitUnlock _ANSI_ARGS_((void));
@@ -1951,6 +1986,8 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks _ANSI_ARGS_((
Tcl_Interp *interp));
MODULE_SCOPE void TclSetBgErrorHandler _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *cmdPrefix));
+MODULE_SCOPE void TclSetProcessGlobalValue _ANSI_ARGS_ ((
+ ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue));
MODULE_SCOPE VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id,
int result));
MODULE_SCOPE int TclSubstTokens _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index eba2fa4..69ddc6a 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.73 2004/11/03 19:13:38 davygrvy Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.74 2004/11/30 19:34:49 dgp Exp $
*/
#ifndef _TCLINTDECLS
@@ -1085,6 +1085,23 @@ EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj * pathPtr,
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * pathPtr, int mode, int permissions));
#endif
+#ifndef TclGetEncodingSearchPath_TCL_DECLARED
+#define TclGetEncodingSearchPath_TCL_DECLARED
+/* 209 */
+EXTERN Tcl_Obj * TclGetEncodingSearchPath _ANSI_ARGS_((void));
+#endif
+#ifndef TclSetEncodingSearchPath_TCL_DECLARED
+#define TclSetEncodingSearchPath_TCL_DECLARED
+/* 210 */
+EXTERN int TclSetEncodingSearchPath _ANSI_ARGS_((
+ Tcl_Obj * searchPath));
+#endif
+#ifndef TclpGetEncodingNameFromEnvironment_TCL_DECLARED
+#define TclpGetEncodingNameFromEnvironment_TCL_DECLARED
+/* 211 */
+EXTERN CONST char * TclpGetEncodingNameFromEnvironment _ANSI_ARGS_((
+ Tcl_DString * bufPtr));
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1314,6 +1331,9 @@ typedef struct TclIntStubs {
int (*tclpObjStat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 206 */
int (*tclpObjAccess) _ANSI_ARGS_((Tcl_Obj * pathPtr, int mode)); /* 207 */
Tcl_Channel (*tclpOpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, int mode, int permissions)); /* 208 */
+ Tcl_Obj * (*tclGetEncodingSearchPath) _ANSI_ARGS_((void)); /* 209 */
+ int (*tclSetEncodingSearchPath) _ANSI_ARGS_((Tcl_Obj * searchPath)); /* 210 */
+ CONST char * (*tclpGetEncodingNameFromEnvironment) _ANSI_ARGS_((Tcl_DString * bufPtr)); /* 211 */
} TclIntStubs;
#ifdef __cplusplus
@@ -2037,6 +2057,18 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclpOpenFileChannel \
(tclIntStubsPtr->tclpOpenFileChannel) /* 208 */
#endif
+#ifndef TclGetEncodingSearchPath
+#define TclGetEncodingSearchPath \
+ (tclIntStubsPtr->tclGetEncodingSearchPath) /* 209 */
+#endif
+#ifndef TclSetEncodingSearchPath
+#define TclSetEncodingSearchPath \
+ (tclIntStubsPtr->tclSetEncodingSearchPath) /* 210 */
+#endif
+#ifndef TclpGetEncodingNameFromEnvironment
+#define TclpGetEncodingNameFromEnvironment \
+ (tclIntStubsPtr->tclpGetEncodingNameFromEnvironment) /* 211 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 194944b..d1cd7f5 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,116 +10,13 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.52 2004/11/22 21:24:30 dgp Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.53 2004/11/30 19:34:49 dgp Exp $
*/
#include "tclInt.h"
#include <stdio.h>
/*
- * In order to find init.tcl during initialization, the following script
- * is invoked by Tcl_Init(). It looks in several different directories:
- *
- * $tcl_library - can specify a primary location, if set,
- * no other locations will be checked. This
- * is the recommended way for a program that
- * embeds Tcl to specifically tell Tcl where
- * to find an init.tcl file.
- *
- * $env(TCL_LIBRARY) - highest priority so user can always override
- * the search path unless the application has
- * specified an exact directory above
- *
- * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl
- * on those platforms where it can determine
- * at runtime the directory where it expects
- * the init.tcl file to be. After [tclInit]
- * reads and uses this value, it [unset]s it.
- * External users of Tcl should not make use
- * of the variable to customize [tclInit].
- *
- * $tcl_libPath - OBSOLETE: This variable is no longer
- * set by Tcl itself, but [tclInit] examines
- * it in case some program that embeds Tcl
- * is customizing [tclInit] by setting this
- * variable to a list of directories in which
- * to search.
- *
- * [tcl::pkgconfig get scriptdir,runtime]
- * - the directory determined by configure to
- * be the place where Tcl's script library
- * is to be installed.
- *
- * The first directory on this path that contains a valid init.tcl script
- * will be set as the value of tcl_library.
- *
- * Note that this entire search mechanism can be bypassed by defining an
- * alternate tclInit procedure before calling Tcl_Init().
- */
-
-static char initScript[] = "if {[info proc tclInit]==\"\"} {\n\
- proc tclInit {} {\n\
- global tcl_libPath tcl_library\n\
- global env tclDefaultLibrary\n\
- variable ::tcl::LibPath\n\
- rename tclInit {}\n\
- set errors {}\n\
- set LibPath {}\n\
- if {[info exists tcl_library]} {\n\
- lappend LibPath $tcl_library\n\
- } else {\n\
- if {[info exists env(TCL_LIBRARY)]} {\n\
- lappend LibPath $env(TCL_LIBRARY)\n\
- if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n\
- if {$tail ne [info tclversion]} {\n\
- lappend LibPath [file join [file dirname\\\n\
- $env(TCL_LIBRARY)] tcl[info tclversion]]\n\
- }\n\
- }\n\
- }\n\
- if {[catch {\n\
- lappend LibPath $tclDefaultLibrary\n\
- unset tclDefaultLibrary\n\
- }]} {\n\
- lappend LibPath [::tcl::pkgconfig get scriptdir,runtime]\n\
- }\n\
- set parentDir [file normalize [file dirname [file dirname\\\n\
- [info nameofexecutable]]]]\n\
- set grandParentDir [file dirname $parentDir]\n\
- lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n\
- lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n\
- lappend LibPath [file join $parentDir library]\n\
- lappend LibPath [file join $grandParentDir library]\n\
- lappend LibPath [file join $grandParentDir\\\n\
- tcl[info patchlevel] library]\n\
- lappend LibPath [file join [file dirname $grandParentDir]\\\n\
- tcl[info patchlevel] library]\n\
- catch {\n\
- set LibPath [concat $LibPath $tcl_libPath]\n\
- }\n\
- }\n\
- foreach i $LibPath {\n\
- set tcl_library $i\n\
- set tclfile [file join $i init.tcl]\n\
- if {[file exists $tclfile]} {\n\
- if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n\
- return\n\
- } else {\n\
- append errors \"$tclfile: $msg\n\"\n\
- append errors \"[dict get $opts -errorinfo]\n\"\n\
- }\n\
- }\n\
- }\n\
- set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
- append msg \" $LibPath\n\n\"\n\
- append msg \"$errors\n\n\"\n\
- append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
- error $msg\n\
- }\n\
-}\n\
-tclInit";
-
-/*
* A pointer to a string that holds an initialization script that if non-NULL
* is evaluated in Tcl_Init() prior to the built-in initialization script
* above. This variable can be modified by the procedure below.
@@ -404,12 +301,182 @@ int
Tcl_Init(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
+ int code;
+ Tcl_DString script, encodingName;
+ Tcl_Obj *path;
+
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
};
}
- return Tcl_Eval(interp, initScript);
+/*
+ * In order to find init.tcl during initialization, the following script
+ * is invoked by Tcl_Init(). It looks in several different directories:
+ *
+ * $tcl_library - can specify a primary location, if set,
+ * no other locations will be checked. This
+ * is the recommended way for a program that
+ * embeds Tcl to specifically tell Tcl where
+ * to find an init.tcl file.
+ *
+ * $env(TCL_LIBRARY) - highest priority so user can always override
+ * the search path unless the application has
+ * specified an exact directory above
+ *
+ * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl
+ * on those platforms where it can determine
+ * at runtime the directory where it expects
+ * the init.tcl file to be. After [tclInit]
+ * reads and uses this value, it [unset]s it.
+ * External users of Tcl should not make use
+ * of the variable to customize [tclInit].
+ *
+ * $tcl_libPath - OBSOLETE: This variable is no longer
+ * set by Tcl itself, but [tclInit] examines
+ * it in case some program that embeds Tcl
+ * is customizing [tclInit] by setting this
+ * variable to a list of directories in which
+ * to search.
+ *
+ * [tcl::pkgconfig get scriptdir,runtime]
+ * - the directory determined by configure to
+ * be the place where Tcl's script library
+ * is to be installed.
+ *
+ * The first directory on this path that contains a valid init.tcl script
+ * will be set as the value of tcl_library.
+ *
+ * Note that this entire search mechanism can be bypassed by defining an
+ * alternate tclInit procedure before calling Tcl_Init().
+ */
+ code = Tcl_Eval(interp,
+"if {[info proc tclInit]==\"\"} {\n"
+" proc tclInit {} {\n"
+" global tcl_libPath tcl_library\n"
+" global env tclDefaultLibrary\n"
+" variable ::tcl::LibPath\n"
+" rename tclInit {}\n"
+" set errors {}\n"
+" set localPath {}\n"
+" set LibPath {}\n"
+" if {[info exists tcl_library]} {\n"
+" lappend localPath $tcl_library\n"
+" } else {\n"
+" if {[info exists env(TCL_LIBRARY)]\n"
+" && [string length $env(TCL_LIBRARY)]} {\n"
+" lappend localPath $env(TCL_LIBRARY)\n"
+" lappend LibPath $env(TCL_LIBRARY)\n"
+" if {[regexp ^tcl(.*)$ [file tail $env(TCL_LIBRARY)] -> tail]} {\n"
+" if {$tail ne [info tclversion]} {\n"
+" lappend localPath [file join [file dirname\\\n"
+" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
+" lappend LibPath [file join [file dirname\\\n"
+" $env(TCL_LIBRARY)] tcl[info tclversion]]\n"
+" }\n"
+" }\n"
+" }\n"
+" if {[catch {\n"
+" lappend localPath $tclDefaultLibrary\n"
+" unset tclDefaultLibrary\n"
+" }]} {\n"
+" lappend localPath [::tcl::pkgconfig get scriptdir,runtime]\n"
+" }\n"
+" set parentDir [file normalize [file dirname [file dirname\\\n"
+" [info nameofexecutable]]]]\n"
+" set grandParentDir [file dirname $parentDir]\n"
+" lappend LibPath [file join $parentDir lib tcl[info tclversion]]\n"
+" lappend LibPath [file join $grandParentDir lib tcl[info tclversion]]\n"
+" lappend LibPath [file join $parentDir library]\n"
+" lappend LibPath [file join $grandParentDir library]\n"
+" lappend LibPath [file join $grandParentDir\\\n"
+" tcl[info patchlevel] library]\n"
+" lappend LibPath [file join [file dirname $grandParentDir]\\\n"
+" tcl[info patchlevel] library]\n"
+" catch {\n"
+" set LibPath [concat $LibPath $tcl_libPath]\n"
+" }\n"
+" }\n"
+" foreach i [concat $localPath $LibPath] {\n"
+" set tcl_library $i\n"
+" set tclfile [file join $i init.tcl]\n"
+" if {[file exists $tclfile]} {\n"
+" if {![catch {uplevel #0 [list source $tclfile]} msg opts]} {\n"
+" return\n"
+" } else {\n"
+" append errors \"$tclfile: $msg\n\"\n"
+" append errors \"[dict get $opts -errorinfo]\n\"\n"
+" }\n"
+" }\n"
+" }\n"
+" set msg \"Can't find a usable init.tcl in the following directories: \n\"\n"
+" append msg \" $localPath $LibPath\n\n\"\n"
+" append msg \"$errors\n\n\"\n"
+" append msg \"This probably means that Tcl wasn't installed properly.\n\"\n"
+" error $msg\n"
+" }\n"
+"}\n"
+"tclInit");
+
+ if (code != TCL_OK) {
+ return code;
+ }
+
+ /*
+ * Now that [info library] is initialized, make sure that
+ * [file join [info library] encoding] is on the encoding
+ * search path.
+ *
+ * Relying on use of original built-in commands.
+ * Should be a safe assumption during interp initialization.
+ * More robust would be to use C-coded equivalents, but that's such
+ * a pain...
+ */
+
+ Tcl_DStringInit(&script);
+ Tcl_DStringAppend(&script, "lsearch -exact", -1);
+ path = Tcl_DuplicateObj(TclGetEncodingSearchPath());
+ Tcl_IncrRefCount(path);
+ Tcl_DStringAppendElement(&script, Tcl_GetString(path));
+ Tcl_DStringAppend(&script, " [file join [info library] encoding]", -1);
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
+ Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&script);
+ if (code == TCL_OK) {
+ int index;
+ Tcl_GetIntFromObj(interp, Tcl_GetObjResult(interp), &index);
+ if (index != -1) {
+ /* [info library]/encoding already on the encoding search path */
+ goto done;
+ }
+ }
+ Tcl_DStringInit(&script);
+ Tcl_DStringAppend(&script, "file join [info library] encoding", -1);
+ code = Tcl_EvalEx(interp, Tcl_DStringValue(&script),
+ Tcl_DStringLength(&script), TCL_EVAL_GLOBAL);
+ Tcl_DStringFree(&script);
+ if (code == TCL_OK) {
+ Tcl_ListObjAppendElement(NULL, path, Tcl_GetObjResult(interp));
+ TclSetEncodingSearchPath(path);
+ }
+done:
+ /*
+ * Now that we know the distributed *.enc files are on the encoding
+ * search path, check whether the [encoding system] matches that
+ * specified by the environment, and if not, attempt to correct it
+ */
+ TclpGetEncodingNameFromEnvironment(&encodingName);
+ if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) {
+ code = Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName));
+ if (code == TCL_ERROR) {
+ Tcl_Panic("system encoding \"", Tcl_DStringValue(&encodingName),
+ "\" not available");
+ }
+ }
+ Tcl_DStringFree(&encodingName);
+ Tcl_DecrRefCount(path);
+ Tcl_ResetResult(interp);
+ return TCL_OK;
}
/*
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 3f62d1a..e5a438f 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNotify.c,v 1.15 2004/07/15 21:17:03 vasiljevic Exp $
+ * RCS: @(#) $Id: tclNotify.c,v 1.16 2004/11/30 19:34:49 dgp Exp $
*/
#include "tclInt.h"
@@ -81,7 +81,7 @@ static Tcl_ThreadDataKey dataKey;
* be replaced with a hashtable.
*/
-static ThreadSpecificData *firstNotifierPtr;
+static ThreadSpecificData *firstNotifierPtr = NULL;
TCL_DECLARE_MUTEX(listLock)
/*
@@ -111,15 +111,22 @@ static void QueueEvent _ANSI_ARGS_((ThreadSpecificData *tsdPtr,
void
TclInitNotifier()
{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr;
+ Tcl_ThreadId threadId = Tcl_GetCurrentThread();
Tcl_MutexLock(&listLock);
-
- tsdPtr->threadId = Tcl_GetCurrentThread();
- tsdPtr->clientData = tclStubs.tcl_InitNotifier();
- tsdPtr->nextPtr = firstNotifierPtr;
- firstNotifierPtr = tsdPtr;
-
+ for (tsdPtr = firstNotifierPtr; tsdPtr && tsdPtr->threadId != threadId;
+ tsdPtr = tsdPtr->nextPtr) {
+ /* Empty loop body. */
+ }
+ if (NULL == tsdPtr) {
+ /* Notifier not yet initialized in this thread */
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->threadId = threadId;
+ tsdPtr->clientData = tclStubs.tcl_InitNotifier();
+ tsdPtr->nextPtr = firstNotifierPtr;
+ firstNotifierPtr = tsdPtr;
+ }
Tcl_MutexUnlock(&listLock);
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index bfa7d86..c1c2dd0 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.107 2004/11/13 00:19:10 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.108 2004/11/30 19:34:49 dgp Exp $
*/
#include "tclInt.h"
@@ -293,6 +293,9 @@ TclIntStubs tclIntStubs = {
TclpObjStat, /* 206 */
TclpObjAccess, /* 207 */
TclpOpenFileChannel, /* 208 */
+ TclGetEncodingSearchPath, /* 209 */
+ TclSetEncodingSearchPath, /* 210 */
+ TclpGetEncodingNameFromEnvironment, /* 211 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index c8006d4..c2f9dd0 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.85 2004/10/07 22:01:18 dgp Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.86 2004/11/30 19:34:50 dgp Exp $
*/
#define TCL_TEST
@@ -1818,9 +1818,9 @@ TestencodingObjCmd(dummy, interp, objc, objv)
}
case ENC_PATH: {
if (objc == 2) {
- Tcl_SetObjResult(interp, TclGetLibraryPath());
+ Tcl_SetObjResult(interp, TclGetEncodingSearchPath());
} else {
- TclSetLibraryPath(objv[2]);
+ TclSetEncodingSearchPath(objv[2]);
}
break;
}
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 068a20b..9737c4a 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -11,23 +11,39 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUtil.c,v 1.48 2004/10/14 15:06:03 dkf Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.49 2004/11/30 19:34:50 dgp Exp $
*/
#include "tclInt.h"
/*
- * The following variable holds the full path name of the binary
+ * The following variables hold the full path name of the binary
* from which this application was executed, or NULL if it isn't
- * know. The value of the variable is set by the procedure
- * Tcl_FindExecutable. The storage space is dynamically allocated.
+ * know. The values are set by the procedure Tcl_FindExecutable.
+ * Only the first call to Tcl_FindExecutable sets the value. That
+ * call also sets the "searchDone" flag, so that subsequent calls
+ * are no-ops. With that logic in place, no mutex protection is
+ * required. The storage space is dynamically allocated. The value
+ * is kept in the system encoding.
*/
-char *tclExecutableName = NULL;
char *tclNativeExecutableName = NULL;
int tclFindExecutableSearchDone = 0;
/*
+ * A copy of the executable path name, converted to Tcl's internal
+ * encoding, UTF-8. Also keep a copy of what the system encoding
+ * was believed to be when the conversion was done, just in case
+ * it's changed on us. Because Tcl_GetNameOfExecutable() is in
+ * the public API, it might be called from any thread, so we need
+ * mutex protection here.
+ */
+
+TCL_DECLARE_MUTEX(executableNameMutex)
+static char *executableName = NULL;
+static Tcl_Encoding conversionEncoding = NULL;
+
+/*
* The following values are used in the flags returned by Tcl_ScanElement
* and used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and
* TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value
@@ -73,9 +89,16 @@ TCL_DECLARE_MUTEX(precisionMutex)
* Prototypes for procedures defined later in this file.
*/
-static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
-static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
+static void ClearHash _ANSI_ARGS_((Tcl_HashTable *tablePtr));
+static void FreeExecutableName _ANSI_ARGS_((ClientData));
+static void FreeProcessGlobalValue _ANSI_ARGS_((
+ ClientData clientData));
+static void FreeThreadHash _ANSI_ARGS_ ((ClientData clientData));
+static Tcl_HashTable * GetThreadHash _ANSI_ARGS_ ((Tcl_ThreadDataKey *keyPtr));
+static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objPtr));
+static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
+static Tcl_Obj * Tcl_GetObjNameOfExecutable();
/*
* The following is the Tcl object type definition for an object
@@ -2564,6 +2587,239 @@ TclCheckBadOctal(interp, value)
/*
*----------------------------------------------------------------------
*
+ * ClearHash --
+ * Remove all the entries in the hash table *tablePtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ClearHash(tablePtr)
+ Tcl_HashTable *tablePtr;
+{
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+
+ for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+ Tcl_DecrRefCount(objPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetThreadHash --
+ *
+ * Get a thread-specific (Tcl_HashTable *) associated with a
+ * thread data key.
+ *
+ * Results:
+ * The Tcl_HashTable * corresponding to *keyPtr.
+ *
+ * Side effects:
+ * The first call on a keyPtr in each thread creates a new
+ * Tcl_HashTable, and registers a thread exit handler to
+ * dispose of it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_HashTable *
+GetThreadHash(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
+ Tcl_GetThreadData(keyPtr, (int)sizeof(Tcl_HashTable *));
+ if (NULL == *tablePtrPtr) {
+ *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
+ Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr);
+ Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
+ }
+ return *tablePtrPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeThreadHash --
+ * Thread exit handler used by GetThreadHash to dispose
+ * of a thread hash table.
+ *
+ * Side effects:
+ * Frees a Tcl_HashTable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeThreadHash(clientData)
+ ClientData clientData;
+{
+ Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
+ Tcl_DeleteHashTable(tablePtr);
+ ckfree((char *) tablePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeProcessGlobalValue --
+ * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup
+ * a ProcessGlobalValue at exit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeProcessGlobalValue(clientData)
+ ClientData clientData;
+{
+ ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
+ pgvPtr->epoch++;
+ pgvPtr->numBytes = 0;
+ ckfree(pgvPtr->value);
+ pgvPtr->value = NULL;
+ if (pgvPtr->encoding) {
+ Tcl_FreeEncoding(pgvPtr->encoding);
+ pgvPtr->encoding = NULL;
+ }
+ Tcl_MutexFinalize(&pgvPtr->mutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetProcessGlobalValue --
+ *
+ * Utility routine to set a global value shared by all threads in
+ * the process while keeping a thread-local copy as well.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclSetProcessGlobalValue(pgvPtr, newValue)
+ ProcessGlobalValue *pgvPtr;
+ Tcl_Obj *newValue;
+{
+ CONST char *bytes;
+ Tcl_HashTable *cacheMap;
+ Tcl_HashEntry *hPtr;
+ int dummy;
+
+ Tcl_MutexLock(&pgvPtr->mutex);
+ /* Fill the global string value */
+ pgvPtr->epoch++;
+ if (NULL != pgvPtr->value) {
+ ckfree(pgvPtr->value);
+ } else {
+ Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
+ }
+ bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
+ pgvPtr->value = ckalloc((unsigned int) pgvPtr->numBytes + 1);
+ strcpy(pgvPtr->value, bytes);
+ if (pgvPtr->encoding) {
+ Tcl_FreeEncoding(pgvPtr->encoding);
+ pgvPtr->encoding = NULL;
+ }
+
+ /*
+ * Fill the local thread copy directly with the Tcl_Obj
+ * value to avoid loss of the intrep
+ */
+ cacheMap = GetThreadHash(&pgvPtr->key);
+ ClearHash(cacheMap);
+ hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
+ Tcl_SetHashValue(hPtr, (ClientData) newValue);
+ Tcl_IncrRefCount(newValue);
+ Tcl_MutexUnlock(&pgvPtr->mutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetProcessGlobalValue --
+ *
+ * Retrieve a global value shared among all threads of the process,
+ * preferring a thread-local copy as long as it remains valid.
+ *
+ * Results:
+ * Returns a (Tcl_Obj *) that holds a copy of the global value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclGetProcessGlobalValue(pgvPtr)
+ ProcessGlobalValue *pgvPtr;
+{
+ Tcl_Obj *value = NULL;
+ Tcl_HashTable *cacheMap;
+ Tcl_HashEntry *hPtr;
+
+ Tcl_MutexLock(&pgvPtr->mutex);
+ if (pgvPtr->encoding) {
+ Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
+ if (pgvPtr->encoding != current) {
+
+ /*
+ * The system encoding has changed since the master
+ * string value was saved. Convert the master value
+ * to be based on the new system encoding.
+ */
+
+ Tcl_DString native, newValue;
+
+ pgvPtr->epoch++;
+ Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
+ pgvPtr->numBytes, &native);
+ Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
+ Tcl_DStringLength(&native), &newValue);
+ Tcl_DStringFree(&native);
+ ckfree(pgvPtr->value);
+ pgvPtr->value = ckalloc((unsigned int)
+ Tcl_DStringLength(&newValue) + 1);
+ memcpy((VOID *) pgvPtr->value, (VOID *) Tcl_DStringValue(&newValue),+ (size_t) Tcl_DStringLength(&newValue) + 1);
+ Tcl_DStringFree(&newValue);
+ Tcl_FreeEncoding(pgvPtr->encoding);
+ pgvPtr->encoding = current;
+ } else {
+ Tcl_FreeEncoding(current);
+ }
+ }
+ cacheMap = GetThreadHash(&pgvPtr->key);
+ hPtr = Tcl_FindHashEntry(cacheMap, (char *)pgvPtr->epoch);
+ if (NULL == hPtr) {
+ int dummy;
+
+ /* No cache for the current epoch - must be a new one */
+ /* First, clear the cacheMap, as anything in it must
+ * refer to some expired epoch.*/
+ ClearHash(cacheMap);
+
+ /* If no thread has set the shared value, call the initializer */
+ if (NULL == pgvPtr->value) {
+ (*(pgvPtr->proc))(&pgvPtr->value, &pgvPtr->numBytes,
+ &pgvPtr->encoding);
+ Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
+ }
+
+
+ /* Store a copy of the shared value in our epoch-indexed cache */
+ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
+ hPtr = Tcl_CreateHashEntry(cacheMap, (char *)pgvPtr->epoch, &dummy);
+ Tcl_SetHashValue(hPtr, (ClientData) value);
+ Tcl_IncrRefCount(value);
+ }
+ Tcl_MutexUnlock(&pgvPtr->mutex);
+ return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_GetNameOfExecutable --
*
* This procedure simply returns a pointer to the internal full
@@ -2571,6 +2827,8 @@ TclCheckBadOctal(interp, value)
* Tcl_FindExecutable. This procedure call is the C API
* equivalent to the "info nameofexecutable" command.
*
+ * TODO: Rework these routines to use a ProcessGlobalValue.
+ *
* Results:
* A pointer to the internal string or NULL if the internal full
* path name has not been computed or unknown.
@@ -2582,12 +2840,68 @@ TclCheckBadOctal(interp, value)
*----------------------------------------------------------------------
*/
+static void
+FreeExecutableName(clientData)
+ ClientData clientData;
+{
+ Tcl_FreeEncoding(conversionEncoding);
+ conversionEncoding = NULL;
+ if (NULL != executableName) {
+ ckfree(executableName);
+ }
+ executableName = NULL;
+}
+
+static Tcl_Obj *
+Tcl_GetObjNameOfExecutable()
+{
+ Tcl_Obj *result;
+
+ Tcl_MutexLock(&executableNameMutex);
+ if (NULL == conversionEncoding) {
+ /* First call (after free) */
+ conversionEncoding = Tcl_GetEncoding(NULL, NULL);
+ Tcl_CreateExitHandler(FreeExecutableName, NULL);
+ } else {
+ /* Later call... */
+ Tcl_Encoding systemEncoding = Tcl_GetEncoding(NULL, NULL);
+ if (systemEncoding != conversionEncoding) {
+ /* ...with system encoding changed */
+ FreeExecutableName(NULL);
+ conversionEncoding = systemEncoding;
+ } else {
+ Tcl_FreeEncoding(systemEncoding);
+ }
+ }
+ if (NULL == tclNativeExecutableName) {
+ FreeExecutableName(NULL);
+ } else if (NULL == executableName) {
+ Tcl_DString ds;
+ Tcl_ExternalToUtfDString(conversionEncoding,
+ tclNativeExecutableName, -1, &ds);
+ executableName = (char *)
+ ckalloc ((unsigned) Tcl_DStringLength(&ds) + 1);
+ strcpy(executableName, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ }
+
+ if (NULL == executableName) {
+ result = Tcl_NewObj();
+ } else {
+ result = Tcl_NewStringObj(executableName, -1);
+ }
+ Tcl_MutexUnlock(&executableNameMutex);
+ return result;
+}
+
CONST char *
Tcl_GetNameOfExecutable()
{
- return tclExecutableName;
+ Tcl_DecrRefCount(Tcl_GetObjNameOfExecutable());
+ return executableName;
}
+
/*
*----------------------------------------------------------------------
*
generated by cgit v0.12 at 2024-11-07 06:02:14 (GMT)