Merge commit '98acd3f494b28ddd8c345a2bb9311e41e2d56ddd' as 'tcl8.6'

1 files changed, 744 insertions, 0 deletions

diff --git a/tcl8.6/generic/tclEnv.c b/tcl8.6/generic/tclEnv.c
new file mode 100644
index 0000000..66ddb57
--- /dev/null
+++ b/tcl8.6/generic/tclEnv.c
@@ -0,0 +1,744 @@
+/*
+ * tclEnv.c --
+ *
+ *	Tcl support for environment variables, including a setenv function.
+ *	This file contains the generic portion of the environment module. It
+ *	is primarily responsible for keeping the "env" arrays in sync with the
+ *	system environment variables.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+
+TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ. */
+
+static struct {
+    int cacheSize;		/* Number of env strings in cache. */
+    char **cache;		/* Array containing all of the environment
+				 * strings that Tcl has allocated. */
+#ifndef USE_PUTENV
+    char **ourEnviron;		/* Cache of the array that we allocate. We
+				 * need to track this in case another
+				 * subsystem swaps around the environ array
+				 * like we do. */
+    int ourEnvironSize;		/* Non-zero means that the environ array was
+				 * malloced and has this many total entries
+				 * allocated to it (not all may be in use at
+				 * once). Zero means that the environment
+				 * array is in its original static state. */
+#endif
+} env;
+
+/*
+ * Declarations for local functions defined in this file:
+ */
+
+static char *		EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
+			    const char *name1, const char *name2, int flags);
+static void		ReplaceString(const char *oldStr, char *newStr);
+MODULE_SCOPE void	TclSetEnv(const char *name, const char *value);
+MODULE_SCOPE void	TclUnsetEnv(const char *name);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetupEnv --
+ *
+ *	This function is invoked for an interpreter to make environment
+ *	variables accessible from that interpreter via the "env" associative
+ *	array.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The interpreter is added to a list of interpreters managed by us, so
+ *	that its view of envariables can be kept consistent with the view in
+ *	other interpreters. If this is the first call to TclSetupEnv, then
+ *	additional initialization happens, such as copying the environment to
+ *	dynamically-allocated space for ease of management.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetupEnv(
+    Tcl_Interp *interp)		/* Interpreter whose "env" array is to be
+				 * managed. */
+{
+    Var *varPtr, *arrayPtr;
+    Tcl_Obj *varNamePtr;
+    Tcl_DString envString;
+    Tcl_HashTable namesHash;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashSearch search;
+
+    /*
+     * Synchronize the values in the environ array with the contents of the
+     * Tcl "env" variable. To do this:
+     *    1) Remove the trace that fires when the "env" var is updated.
+     *    2) Find the existing contents of the "env", storing in a hash table.
+     *    3) Create/update elements for each environ variable, removing
+     *	     elements from the hash table as we go.
+     *    4) Remove the elements for each remaining entry in the hash table,
+     *	     which must have existed before yet have no analog in the environ
+     *	     variable.
+     *    5) Add a trace that synchronizes the "env" array.
+     */
+
+    Tcl_UntraceVar2(interp, "env", NULL,
+	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+	    TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
+
+    /*
+     * Find out what elements are currently in the global env array.
+     */
+
+    TclNewLiteralStringObj(varNamePtr, "env");
+    Tcl_IncrRefCount(varNamePtr);
+    Tcl_InitObjHashTable(&namesHash);
+    varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
+	    /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+    TclFindArrayPtrElements(varPtr, &namesHash);
+
+    /*
+     * Go through the environment array and transfer its values into Tcl. At
+     * the same time, remove those elements we add/update from the hash table
+     * of existing elements, so that after this part processes, that table
+     * will hold just the parts to remove.
+     */
+
+    if (environ[0] != NULL) {
+	int i;
+
+	Tcl_MutexLock(&envMutex);
+	for (i = 0; environ[i] != NULL; i++) {
+	    Tcl_Obj *obj1, *obj2;
+	    char *p1, *p2;
+
+	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
+	    p2 = strchr(p1, '=');
+	    if (p2 == NULL) {
+		/*
+		 * This condition seem to happen occasionally under some
+		 * versions of Solaris, or when encoding accidents swallow the
+		 * '='; ignore the entry.
+		 */
+
+		continue;
+	    }
+	    p2++;
+	    p2[-1] = '\0';
+	    obj1 = Tcl_NewStringObj(p1, -1);
+	    obj2 = Tcl_NewStringObj(p2, -1);
+	    Tcl_DStringFree(&envString);
+
+	    Tcl_IncrRefCount(obj1);
+	    Tcl_IncrRefCount(obj2);
+	    Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
+	    hPtr = Tcl_FindHashEntry(&namesHash, obj1);
+	    if (hPtr != NULL) {
+		Tcl_DeleteHashEntry(hPtr);
+	    }
+	    Tcl_DecrRefCount(obj1);
+	    Tcl_DecrRefCount(obj2);
+	}
+	Tcl_MutexUnlock(&envMutex);
+    }
+
+    /*
+     * Delete those elements that existed in the array but which had no
+     * counterparts in the environment array.
+     */
+
+    for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
+	    hPtr=Tcl_NextHashEntry(&search)) {
+	Tcl_Obj *elemName = Tcl_GetHashValue(hPtr);
+
+	TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
+    }
+    Tcl_DeleteHashTable(&namesHash);
+    Tcl_DecrRefCount(varNamePtr);
+
+    /*
+     * Re-establish the trace.
+     */
+
+    Tcl_TraceVar2(interp, "env", NULL,
+	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
+	    TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSetEnv --
+ *
+ *	Set an environment variable, replacing an existing value or creating a
+ *	new variable if there doesn't exist a variable by the given name. This
+ *	function is intended to be a stand-in for the UNIX "setenv" function
+ *	so that applications using that function will interface properly to
+ *	Tcl. To make it a stand-in, the Makefile must define "TclSetEnv" to
+ *	"setenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The environ array gets updated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSetEnv(
+    const char *name,		/* Name of variable whose value is to be set
+				 * (UTF-8). */
+    const char *value)		/* New value for variable (UTF-8). */
+{
+    Tcl_DString envString;
+    unsigned nameLength, valueLength;
+    int index, length;
+    char *p, *oldValue;
+    const char *p2;
+
+    /*
+     * Figure out where the entry is going to go. If the name doesn't already
+     * exist, enlarge the array if necessary to make room. If the name exists,
+     * free its old entry.
+     */
+
+    Tcl_MutexLock(&envMutex);
+    index = TclpFindVariable(name, &length);
+
+    if (index == -1) {
+#ifndef USE_PUTENV
+	/*
+	 * We need to handle the case where the environment may be changed
+	 * outside our control. ourEnvironSize is only valid if the current
+	 * environment is the one we allocated. [Bug 979640]
+	 */
+
+	if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
+	    char **newEnviron = ckalloc((length + 5) * sizeof(char *));
+
+	    memcpy(newEnviron, environ, length * sizeof(char *));
+	    if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
+		ckfree(env.ourEnviron);
+	    }
+	    environ = env.ourEnviron = newEnviron;
+	    env.ourEnvironSize = length + 5;
+	}
+	index = length;
+	environ[index + 1] = NULL;
+#endif /* USE_PUTENV */
+	oldValue = NULL;
+	nameLength = strlen(name);
+    } else {
+	const char *env;
+
+	/*
+	 * Compare the new value to the existing value. If they're the same
+	 * then quit immediately (e.g. don't rewrite the value or propagate it
+	 * to other interpreters). Otherwise, when there are N interpreters
+	 * there will be N! propagations of the same value among the
+	 * interpreters.
+	 */
+
+	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
+	if (strcmp(value, env + (length + 1)) == 0) {
+	    Tcl_DStringFree(&envString);
+	    Tcl_MutexUnlock(&envMutex);
+	    return;
+	}
+	Tcl_DStringFree(&envString);
+
+	oldValue = environ[index];
+	nameLength = (unsigned) length;
+    }
+
+    /*
+     * Create a new entry. Build a complete UTF string that contains a
+     * "name=value" pattern. Then convert the string to the native encoding,
+     * and set the environ array value.
+     */
+
+    valueLength = strlen(value);
+    p = ckalloc(nameLength + valueLength + 2);
+    memcpy(p, name, nameLength);
+    p[nameLength] = '=';
+    memcpy(p+nameLength+1, value, valueLength+1);
+    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
+
+    /*
+     * Copy the native string to heap memory.
+     */
+
+    p = ckrealloc(p, Tcl_DStringLength(&envString) + 1);
+    memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1);
+    Tcl_DStringFree(&envString);
+
+#ifdef USE_PUTENV
+    /*
+     * Update the system environment.
+     */
+
+    putenv(p);
+    index = TclpFindVariable(name, &length);
+#else
+    environ[index] = p;
+#endif /* USE_PUTENV */
+
+    /*
+     * Watch out for versions of putenv that copy the string (e.g. VC++). In
+     * this case we need to free the string immediately. Otherwise update the
+     * string in the cache.
+     */
+
+    if ((index != -1) && (environ[index] == p)) {
+	ReplaceString(oldValue, p);
+#ifdef HAVE_PUTENV_THAT_COPIES
+    } else {
+	/*
+	 * This putenv() copies instead of taking ownership.
+	 */
+
+	ckfree(p);
+#endif /* HAVE_PUTENV_THAT_COPIES */
+    }
+
+    Tcl_MutexUnlock(&envMutex);
+
+    if (!strcmp(name, "HOME")) {
+	/*
+	 * If the user's home directory has changed, we must invalidate the
+	 * filesystem cache, because '~' expansions will now be incorrect.
+	 */
+
+	Tcl_FSMountsChanged(NULL);
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_PutEnv --
+ *
+ *	Set an environment variable. Similar to setenv except that the
+ *	information is passed in a single string of the form NAME=value,
+ *	rather than as separate name strings. This function is intended to be
+ *	a stand-in for the UNIX "putenv" function so that applications using
+ *	that function will interface properly to Tcl. To make it a stand-in,
+ *	the Makefile will define "Tcl_PutEnv" to "putenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	The environ array gets updated, as do all of the interpreters that we
+ *	manage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_PutEnv(
+    const char *assignment)	/* Info about environment variable in the form
+				 * NAME=value. (native) */
+{
+    Tcl_DString nameString;
+    const char *name;
+    char *value;
+
+    if (assignment == NULL) {
+	return 0;
+    }
+
+    /*
+     * First convert the native string to UTF. Then separate the string into
+     * name and value parts, and call TclSetEnv to do all of the real work.
+     */
+
+    name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
+    value = strchr(name, '=');
+
+    if ((value != NULL) && (value != name)) {
+	value[0] = '\0';
+	TclSetEnv(name, value+1);
+    }
+
+    Tcl_DStringFree(&nameString);
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclUnsetEnv --
+ *
+ *	Remove an environment variable, updating the "env" arrays in all
+ *	interpreters managed by us. This function is intended to replace the
+ *	UNIX "unsetenv" function (but to do this the Makefile must be modified
+ *	to redefine "TclUnsetEnv" to "unsetenv".
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Interpreters are updated, as is environ.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclUnsetEnv(
+    const char *name)		/* Name of variable to remove (UTF-8). */
+{
+    char *oldValue;
+    int length;
+    int index;
+#ifdef USE_PUTENV_FOR_UNSET
+    Tcl_DString envString;
+    char *string;
+#else
+    char **envPtr;
+#endif /* USE_PUTENV_FOR_UNSET */
+
+    Tcl_MutexLock(&envMutex);
+    index = TclpFindVariable(name, &length);
+
+    /*
+     * First make sure that the environment variable exists to avoid doing
+     * needless work and to avoid recursion on the unset.
+     */
+
+    if (index == -1) {
+	Tcl_MutexUnlock(&envMutex);
+	return;
+    }
+
+    /*
+     * Remember the old value so we can free it if Tcl created the string.
+     */
+
+    oldValue = environ[index];
+
+    /*
+     * Update the system environment. This must be done before we update the
+     * interpreters or we will recurse.
+     */
+
+#ifdef USE_PUTENV_FOR_UNSET
+    /*
+     * For those platforms that support putenv to unset, Linux indicates
+     * that no = should be included, and Windows requires it.
+     */
+
+#if defined(_WIN32)
+    string = ckalloc(length + 2);
+    memcpy(string, name, (size_t) length);
+    string[length] = '=';
+    string[length+1] = '\0';
+#else
+    string = ckalloc(length + 1);
+    memcpy(string, name, (size_t) length);
+    string[length] = '\0';
+#endif /* _WIN32 */
+
+    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
+    string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
+    memcpy(string, Tcl_DStringValue(&envString),
+	    (unsigned) Tcl_DStringLength(&envString)+1);
+    Tcl_DStringFree(&envString);
+
+    putenv(string);
+
+    /*
+     * Watch out for versions of putenv that copy the string (e.g. VC++). In
+     * this case we need to free the string immediately. Otherwise update the
+     * string in the cache.
+     */
+
+    if (environ[index] == string) {
+	ReplaceString(oldValue, string);
+#ifdef HAVE_PUTENV_THAT_COPIES
+    } else {
+	/*
+	 * This putenv() copies instead of taking ownership.
+	 */
+
+	ckfree(string);
+#endif /* HAVE_PUTENV_THAT_COPIES */
+    }
+#else /* !USE_PUTENV_FOR_UNSET */
+    for (envPtr = environ+index+1; ; envPtr++) {
+	envPtr[-1] = *envPtr;
+	if (*envPtr == NULL) {
+	    break;
+	}
+    }
+    ReplaceString(oldValue, NULL);
+#endif /* USE_PUTENV_FOR_UNSET */
+
+    Tcl_MutexUnlock(&envMutex);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclGetEnv --
+ *
+ *	Retrieve the value of an environment variable.
+ *
+ * Results:
+ *	The result is a pointer to a string specifying the value of the
+ *	environment variable, or NULL if that environment variable does not
+ *	exist. Storage for the result string is allocated in valuePtr; the
+ *	caller must call Tcl_DStringFree() when the result is no longer
+ *	needed.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+const char *
+TclGetEnv(
+    const char *name,		/* Name of environment variable to find
+				 * (UTF-8). */
+    Tcl_DString *valuePtr)	/* Uninitialized or free DString in which the
+				 * value of the environment variable is
+				 * stored. */
+{
+    int length, index;
+    const char *result;
+
+    Tcl_MutexLock(&envMutex);
+    index = TclpFindVariable(name, &length);
+    result = NULL;
+    if (index != -1) {
+	Tcl_DString envStr;
+
+	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
+	result += length;
+	if (*result == '=') {
+	    result++;
+	    Tcl_DStringInit(valuePtr);
+	    Tcl_DStringAppend(valuePtr, result, -1);
+	    result = Tcl_DStringValue(valuePtr);
+	} else {
+	    result = NULL;
+	}
+	Tcl_DStringFree(&envStr);
+    }
+    Tcl_MutexUnlock(&envMutex);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnvTraceProc --
+ *
+ *	This function is invoked whenever an environment variable is read,
+ *	modified or deleted. It propagates the change to the global "environ"
+ *	array.
+ *
+ * Results:
+ *	Returns NULL to indicate success, or an error-message if the array
+ *	element being handled doesn't exist.
+ *
+ * Side effects:
+ *	Environment variable changes get propagated. If the whole "env" array
+ *	is deleted, then we stop managing things for this interpreter (usually
+ *	this happens because the whole interpreter is being deleted).
+ *
+ *----------------------------------------------------------------------
+ */
+
+	/* ARGSUSED */
+static char *
+EnvTraceProc(
+    ClientData clientData,	/* Not used. */
+    Tcl_Interp *interp,		/* Interpreter whose "env" variable is being
+				 * modified. */
+    const char *name1,		/* Better be "env". */
+    const char *name2,		/* Name of variable being modified, or NULL if
+				 * whole array is being deleted (UTF-8). */
+    int flags)			/* Indicates what's happening. */
+{
+    /*
+     * For array traces, let TclSetupEnv do all the work.
+     */
+
+    if (flags & TCL_TRACE_ARRAY) {
+	TclSetupEnv(interp);
+	return NULL;
+    }
+
+    /*
+     * If name2 is NULL, then return and do nothing.
+     */
+
+    if (name2 == NULL) {
+	return NULL;
+    }
+
+    /*
+     * If a value is being set, call TclSetEnv to do all of the work.
+     */
+
+    if (flags & TCL_TRACE_WRITES) {
+	const char *value;
+
+	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
+	TclSetEnv(name2, value);
+    }
+
+    /*
+     * If a value is being read, call TclGetEnv to do all of the work.
+     */
+
+    if (flags & TCL_TRACE_READS) {
+	Tcl_DString valueString;
+	const char *value = TclGetEnv(name2, &valueString);
+
+	if (value == NULL) {
+	    return (char *) "no such variable";
+	}
+	Tcl_SetVar2(interp, name1, name2, value, 0);
+	Tcl_DStringFree(&valueString);
+    }
+
+    /*
+     * For unset traces, let TclUnsetEnv do all the work.
+     */
+
+    if (flags & TCL_TRACE_UNSETS) {
+	TclUnsetEnv(name2);
+    }
+    return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReplaceString --
+ *
+ *	Replace one string with another in the environment variable cache. The
+ *	cache keeps track of all of the environment variables that Tcl has
+ *	modified so they can be freed later.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May free the old string.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ReplaceString(
+    const char *oldStr,		/* Old environment string. */
+    char *newStr)		/* New environment string. */
+{
+    int i;
+
+    /*
+     * Check to see if the old value was allocated by Tcl. If so, it needs to
+     * be deallocated to avoid memory leaks. Note that this algorithm is O(n),
+     * not O(1). This will result in n-squared behavior if lots of environment
+     * changes are being made.
+     */
+
+    for (i = 0; i < env.cacheSize; i++) {
+	if (env.cache[i]==oldStr || env.cache[i]==NULL) {
+	    break;
+	}
+    }
+    if (i < env.cacheSize) {
+	/*
+	 * Replace or delete the old value.
+	 */
+
+	if (env.cache[i]) {
+	    ckfree(env.cache[i]);
+	}
+
+	if (newStr) {
+	    env.cache[i] = newStr;
+	} else {
+	    for (; i < env.cacheSize-1; i++) {
+		env.cache[i] = env.cache[i+1];
+	    }
+	    env.cache[env.cacheSize-1] = NULL;
+	}
+    } else {
+	/*
+	 * We need to grow the cache in order to hold the new string.
+	 */
+
+	const int growth = 5;
+
+	env.cache = ckrealloc(env.cache,
+		(env.cacheSize + growth) * sizeof(char *));
+	env.cache[env.cacheSize] = newStr;
+	(void) memset(env.cache+env.cacheSize+1, 0,
+		(size_t) (growth-1) * sizeof(char *));
+	env.cacheSize += growth;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEnvironment --
+ *
+ *	This function releases any storage allocated by this module that isn't
+ *	still in use by the global environment. Any strings that are still in
+ *	the environment will be leaked.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May deallocate storage.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFinalizeEnvironment(void)
+{
+    /*
+     * For now we just deallocate the cache array and none of the environment
+     * strings. This may leak more memory that strictly necessary, since some
+     * of the strings may no longer be in the environment. However,
+     * determining which ones are ok to delete is n-squared, and is pretty
+     * unlikely, so we don't bother.
+     */
+
+    if (env.cache) {
+	ckfree(env.cache);
+	env.cache = NULL;
+	env.cacheSize = 0;
+#ifndef USE_PUTENV
+	env.ourEnvironSize = 0;
+#endif
+    }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */