shared_source/c_tcl_base_7_5_w_mods/tclenv.c

/* $Header$ */
/* 
 * tclEnv.c --
 *
 *      Tcl support for environment variables, including a setenv
 *      procedure.  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.
 *
 * RCS: @(#) $Id: tclenv.c,v 1.1.1.1 2001/06/13 04:37:55 dtashley Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)     /* To serialize access to environ */

static int cacheSize = 0;       /* Number of env strings in environCache. */
static char **environCache = NULL;
                                /* Array containing all of the environment
                                 * strings that Tcl has allocated. */

#ifndef USE_PUTENV
static int environSize = 0;     /* 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

/*
 * For MacOS X
 */
#if defined(__APPLE__) && defined(__DYNAMIC__)
#include <crt_externs.h>
char **environ = NULL;
#endif

/*
 * Declarations for local procedures defined in this file:
 */

static char *           EnvTraceProc _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, char *name1, char *name2,
                            int flags));
static void             ReplaceString _ANSI_ARGS_((CONST char *oldStr,
                            char *newStr));
void                    TclSetEnv _ANSI_ARGS_((CONST char *name,
                            CONST char *value));
void                    TclUnsetEnv _ANSI_ARGS_((CONST char *name));


/*
 *----------------------------------------------------------------------
 *
 * TclSetupEnv --
 *
 *      This procedure 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(interp)
    Tcl_Interp *interp;         /* Interpreter whose "env" array is to be
                                 * managed. */
{
    Tcl_DString envString;
    char *p1, *p2;
    int i;

    /*
     * For MacOS X
     */
#if defined(__APPLE__) && defined(__DYNAMIC__)
    environ = *_NSGetEnviron();
#endif

    /*
     * 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 unset.
     *    2) Unset the "env" variable.
     *    3) If there are no environ variables, create an empty "env"
     *       array.  Otherwise populate the array with current values.
     *    4) Add a trace that synchronizes the "env" array.
     */
    
    Tcl_UntraceVar2(interp, "env", (char *) NULL,
            TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
            TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
            (ClientData) NULL);
    
    Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); 
    
    if (environ[0] == NULL) {
        Tcl_Obj *varNamePtr;
        
        varNamePtr = Tcl_NewStringObj("env", -1);
        Tcl_IncrRefCount(varNamePtr);
        TclArraySet(interp, varNamePtr, NULL);  
        Tcl_DecrRefCount(varNamePtr);
    } else {
        Tcl_MutexLock(&envMutex);
        for (i = 0; environ[i] != NULL; i++) {
            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; ignore the entry.
                 */
                
                continue;
            }
            p2++;
            p2[-1] = '\0';
            Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);        
            Tcl_DStringFree(&envString);
        }
        Tcl_MutexUnlock(&envMutex);
    }

    Tcl_TraceVar2(interp, "env", (char *) NULL,
            TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
            TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
            (ClientData) 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 procedure is intended to be a
 *      stand-in for the  UNIX "setenv" procedure so that applications
 *      using that procedure 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(name, value)
    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;
    int index, length, nameLength;
    char *p, *p2, *oldValue;

    /*
     * 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
        if ((length + 2) > environSize) {
            char **newEnviron;

            newEnviron = (char **) ckalloc((unsigned)
                    ((length + 5) * sizeof(char *)));
            memcpy((VOID *) newEnviron, (VOID *) environ,
                    length*sizeof(char *));
            if (environSize != 0) {
                ckfree((char *) environ);
            }
            environ = newEnviron;
            environSize = length + 5;
        }
        index = length;
        environ[index + 1] = NULL;
#endif
        oldValue = NULL;
        nameLength = strlen(name);
    } else {
        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 = 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.
     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);
    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);

    /*
     * Copy the native string to heap memory.
     */
    
    p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
    strcpy(p, p2);
    Tcl_DStringFree(&envString);

#ifdef USE_PUTENV
    /*
     * Update the system environment.
     */

    putenv(p);
    index = TclpFindVariable(name, &length);
#else
    environ[index] = p;
#endif

    /*
     * 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);
    }

    Tcl_MutexUnlock(&envMutex);
}

/*
 *----------------------------------------------------------------------
 *
 * 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 procedure
 *      is intended to be a stand-in for the  UNIX "putenv" procedure
 *      so that applications using that procedure 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(string)
    CONST char *string;         /* Info about environment variable in the
                                 * form NAME=value. (native) */
{
    Tcl_DString nameString;   
    int nameLength;
    char *name, *value;

    if (string == 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, string, -1, &nameString);
    value = strchr(name, '=');
    if (value == NULL) {
        return 0;
    }
    nameLength = value - name;
    if (nameLength == 0) {
        return 0;
    }

    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(name)
    CONST char *name;           /* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    int length, index;
#ifdef USE_PUTENV
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif

    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
    string = ckalloc(length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
    
    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
    strcpy(string, Tcl_DStringValue(&envString));
    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);
    }
#else
    for (envPtr = environ+index+1; ; envPtr++) {
        envPtr[-1] = *envPtr;
        if (*envPtr == NULL) {
            break;
        }
    }
    ReplaceString(oldValue, NULL);
#endif

    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.
 *
 *----------------------------------------------------------------------
 */

char *
TclGetEnv(name, valuePtr)
    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;
    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 procedure is invoked whenever an environment variable
 *      is read, modified or deleted.  It propagates the change to the global
 *      "environ" array.
 *
 * Results:
 *      Always returns NULL to indicate success.
 *
 * 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, interp, name1, name2, flags)
    ClientData clientData;      /* Not used. */
    Tcl_Interp *interp;         /* Interpreter whose "env" variable is
                                 * being modified. */
    char *name1;                /* Better be "env". */
    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) {
        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;
        char *value;

        value = TclGetEnv(name2, &valueString);
        if (value == NULL) {
            return "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(oldStr, newStr)
    CONST char *oldStr;         /* Old environment string. */
    char *newStr;               /* New environment string. */
{
    int i;
    char **newCache;

    /*
     * 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 < cacheSize; i++) {
        if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
            break;
        }
    }
    if (i < cacheSize) {
        /*
         * Replace or delete the old value.
         */

        if (environCache[i]) {
            ckfree(environCache[i]);
        }
            
        if (newStr) {
            environCache[i] = newStr;
        } else {
            for (; i < cacheSize-1; i++) {
                environCache[i] = environCache[i+1];
            }
            environCache[cacheSize-1] = NULL;
        }
    } else {    
        int allocatedSize = (cacheSize + 5) * sizeof(char *);

        /*
         * We need to grow the cache in order to hold the new string.
         */

        newCache = (char **) ckalloc((unsigned) allocatedSize);
        (VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
        
        if (environCache) {
            memcpy((VOID *) newCache, (VOID *) environCache,
                    (size_t) (cacheSize * sizeof(char*)));
            ckfree((char *) environCache);
        }
        environCache = newCache;
        environCache[cacheSize] = (char *) newStr;
        environCache[cacheSize+1] = NULL;
        cacheSize += 5;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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()
{
    /*
     * 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 (environCache) {
        ckfree((char *) environCache);
        environCache = NULL;
        cacheSize    = 0;
#ifndef USE_PUTENV
        environSize  = 0;
#endif
    }
}

/* End of tclenv.c */
1	/* $Header$ */
2	/*
3	* tclEnv.c --
4	*
5	* Tcl support for environment variables, including a setenv
6	* procedure. This file contains the generic portion of the
7	* environment module. It is primarily responsible for keeping
8	* the "env" arrays in sync with the system environment variables.
9	*
10	* Copyright (c) 1991-1994 The Regents of the University of California.
11	* Copyright (c) 1994-1998 Sun Microsystems, Inc.
12	*
13	* See the file "license.terms" for information on usage and redistribution
14	* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15	*
16	* RCS: @(#) $Id: tclenv.c,v 1.1.1.1 2001/06/13 04:37:55 dtashley Exp $
17	*/
18
19	#include "tclInt.h"
20	#include "tclPort.h"
21
22	TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */
23
24	static int cacheSize = 0; /* Number of env strings in environCache. */
25	static char **environCache = NULL;
26	/* Array containing all of the environment
27	* strings that Tcl has allocated. */
28
29	#ifndef USE_PUTENV
30	static int environSize = 0; /* Non-zero means that the environ array was
31	* malloced and has this many total entries
32	* allocated to it (not all may be in use at
33	* once). Zero means that the environment
34	* array is in its original static state. */
35	#endif
36
37	/*
38	* For MacOS X
39	*/
40	#if defined(__APPLE__) && defined(__DYNAMIC__)
41	#include <crt_externs.h>
42	char **environ = NULL;
43	#endif
44
45	/*
46	* Declarations for local procedures defined in this file:
47	*/
48
49	static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
50	Tcl_Interp interp, char name1, char *name2,
51	int flags));
52	static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
53	char *newStr));
54	void TclSetEnv _ANSI_ARGS_((CONST char *name,
55	CONST char *value));
56	void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
57
58
59	/*
60	*----------------------------------------------------------------------
61	*
62	* TclSetupEnv --
63	*
64	* This procedure is invoked for an interpreter to make environment
65	* variables accessible from that interpreter via the "env"
66	* associative array.
67	*
68	* Results:
69	* None.
70	*
71	* Side effects:
72	* The interpreter is added to a list of interpreters managed
73	* by us, so that its view of envariables can be kept consistent
74	* with the view in other interpreters. If this is the first
75	* call to TclSetupEnv, then additional initialization happens,
76	* such as copying the environment to dynamically-allocated space
77	* for ease of management.
78	*
79	*----------------------------------------------------------------------
80	*/
81
82	void
83	TclSetupEnv(interp)
84	Tcl_Interp interp; / Interpreter whose "env" array is to be
85	* managed. */
86	{
87	Tcl_DString envString;
88	char p1, p2;
89	int i;
90
91	/*
92	* For MacOS X
93	*/
94	#if defined(__APPLE__) && defined(__DYNAMIC__)
95	environ = *_NSGetEnviron();
96	#endif
97
98	/*
99	* Synchronize the values in the environ array with the contents
100	* of the Tcl "env" variable. To do this:
101	* 1) Remove the trace that fires when the "env" var is unset.
102	* 2) Unset the "env" variable.
103	* 3) If there are no environ variables, create an empty "env"
104	* array. Otherwise populate the array with current values.
105	* 4) Add a trace that synchronizes the "env" array.
106	*/
107
108	Tcl_UntraceVar2(interp, "env", (char *) NULL,
109	TCL_GLOBAL_ONLY \| TCL_TRACE_WRITES \| TCL_TRACE_UNSETS \|
110	TCL_TRACE_READS \| TCL_TRACE_ARRAY, EnvTraceProc,
111	(ClientData) NULL);
112
113	Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);
114
115	if (environ[0] == NULL) {
116	Tcl_Obj *varNamePtr;
117
118	varNamePtr = Tcl_NewStringObj("env", -1);
119	Tcl_IncrRefCount(varNamePtr);
120	TclArraySet(interp, varNamePtr, NULL);
121	Tcl_DecrRefCount(varNamePtr);
122	} else {
123	Tcl_MutexLock(&envMutex);
124	for (i = 0; environ[i] != NULL; i++) {
125	p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
126	p2 = strchr(p1, '=');
127	if (p2 == NULL) {
128	/*
129	* This condition seem to happen occasionally under some
130	* versions of Solaris; ignore the entry.
131	*/
132
133	continue;
134	}
135	p2++;
136	p2[-1] = '\0';
137	Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);
138	Tcl_DStringFree(&envString);
139	}
140	Tcl_MutexUnlock(&envMutex);
141	}
142
143	Tcl_TraceVar2(interp, "env", (char *) NULL,
144	TCL_GLOBAL_ONLY \| TCL_TRACE_WRITES \| TCL_TRACE_UNSETS \|
145	TCL_TRACE_READS \| TCL_TRACE_ARRAY, EnvTraceProc,
146	(ClientData) NULL);
147	}
148
149	/*
150	*----------------------------------------------------------------------
151	*
152	* TclSetEnv --
153	*
154	* Set an environment variable, replacing an existing value
155	* or creating a new variable if there doesn't exist a variable
156	* by the given name. This procedure is intended to be a
157	* stand-in for the UNIX "setenv" procedure so that applications
158	* using that procedure will interface properly to Tcl. To make
159	* it a stand-in, the Makefile must define "TclSetEnv" to "setenv".
160	*
161	* Results:
162	* None.
163	*
164	* Side effects:
165	* The environ array gets updated.
166	*
167	*----------------------------------------------------------------------
168	*/
169
170	void
171	TclSetEnv(name, value)
172	CONST char name; / Name of variable whose value is to be
173	* set (UTF-8). */
174	CONST char value; / New value for variable (UTF-8). */
175	{
176	Tcl_DString envString;
177	int index, length, nameLength;
178	char p, p2, *oldValue;
179
180	/*
181	* Figure out where the entry is going to go. If the name doesn't
182	* already exist, enlarge the array if necessary to make room. If the
183	* name exists, free its old entry.
184	*/
185
186	Tcl_MutexLock(&envMutex);
187	index = TclpFindVariable(name, &length);
188
189	if (index == -1) {
190	#ifndef USE_PUTENV
191	if ((length + 2) > environSize) {
192	char **newEnviron;
193
194	newEnviron = (char **) ckalloc((unsigned)
195	((length + 5) * sizeof(char *)));
196	memcpy((VOID ) newEnviron, (VOID ) environ,
197	lengthsizeof(char ));
198	if (environSize != 0) {
199	ckfree((char *) environ);
200	}
201	environ = newEnviron;
202	environSize = length + 5;
203	}
204	index = length;
205	environ[index + 1] = NULL;
206	#endif
207	oldValue = NULL;
208	nameLength = strlen(name);
209	} else {
210	char *env;
211
212	/*
213	* Compare the new value to the existing value. If they're
214	* the same then quit immediately (e.g. don't rewrite the
215	* value or propagate it to other interpreters). Otherwise,
216	* when there are N interpreters there will be N! propagations
217	* of the same value among the interpreters.
218	*/
219
220	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
221	if (strcmp(value, (env + length + 1)) == 0) {
222	Tcl_DStringFree(&envString);
223	Tcl_MutexUnlock(&envMutex);
224	return;
225	}
226	Tcl_DStringFree(&envString);
227
228	oldValue = environ[index];
229	nameLength = length;
230	}
231
232
233	/*
234	* Create a new entry. Build a complete UTF string that contains
235	* a "name=value" pattern. Then convert the string to the native
236	* encoding, and set the environ array value.
237	*/
238
239	p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
240	strcpy(p, name);
241	p[nameLength] = '=';
242	strcpy(p+nameLength+1, value);
243	p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
244
245	/*
246	* Copy the native string to heap memory.
247	*/
248
249	p = (char *) ckrealloc(p, (unsigned) (strlen(p2) + 1));
250	strcpy(p, p2);
251	Tcl_DStringFree(&envString);
252
253	#ifdef USE_PUTENV
254	/*
255	* Update the system environment.
256	*/
257
258	putenv(p);
259	index = TclpFindVariable(name, &length);
260	#else
261	environ[index] = p;
262	#endif
263
264	/*
265	* Watch out for versions of putenv that copy the string (e.g. VC++).
266	* In this case we need to free the string immediately. Otherwise
267	* update the string in the cache.
268	*/
269
270	if ((index != -1) && (environ[index] == p)) {
271	ReplaceString(oldValue, p);
272	}
273
274	Tcl_MutexUnlock(&envMutex);
275	}
276
277	/*
278	*----------------------------------------------------------------------
279	*
280	* Tcl_PutEnv --
281	*
282	* Set an environment variable. Similar to setenv except that
283	* the information is passed in a single string of the form
284	* NAME=value, rather than as separate name strings. This procedure
285	* is intended to be a stand-in for the UNIX "putenv" procedure
286	* so that applications using that procedure will interface
287	* properly to Tcl. To make it a stand-in, the Makefile will
288	* define "Tcl_PutEnv" to "putenv".
289	*
290	* Results:
291	* None.
292	*
293	* Side effects:
294	* The environ array gets updated, as do all of the interpreters
295	* that we manage.
296	*
297	*----------------------------------------------------------------------
298	*/
299
300	int
301	Tcl_PutEnv(string)
302	CONST char string; / Info about environment variable in the
303	* form NAME=value. (native) */
304	{
305	Tcl_DString nameString;
306	int nameLength;
307	char name, value;
308
309	if (string == NULL) {
310	return 0;
311	}
312
313	/*
314	* First convert the native string to UTF. Then separate the
315	* string into name and value parts, and call TclSetEnv to do
316	* all of the real work.
317	*/
318
319	name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
320	value = strchr(name, '=');
321	if (value == NULL) {
322	return 0;
323	}
324	nameLength = value - name;
325	if (nameLength == 0) {
326	return 0;
327	}
328
329	value[0] = '\0';
330	TclSetEnv(name, value+1);
331	Tcl_DStringFree(&nameString);
332	return 0;
333	}
334
335	/*
336	*----------------------------------------------------------------------
337	*
338	* TclUnsetEnv --
339	*
340	* Remove an environment variable, updating the "env" arrays
341	* in all interpreters managed by us. This function is intended
342	* to replace the UNIX "unsetenv" function (but to do this the
343	* Makefile must be modified to redefine "TclUnsetEnv" to
344	* "unsetenv".
345	*
346	* Results:
347	* None.
348	*
349	* Side effects:
350	* Interpreters are updated, as is environ.
351	*
352	*----------------------------------------------------------------------
353	*/
354
355	void
356	TclUnsetEnv(name)
357	CONST char name; / Name of variable to remove (UTF-8). */
358	{
359	char *oldValue;
360	int length, index;
361	#ifdef USE_PUTENV
362	Tcl_DString envString;
363	char *string;
364	#else
365	char **envPtr;
366	#endif
367
368	Tcl_MutexLock(&envMutex);
369	index = TclpFindVariable(name, &length);
370
371	/*
372	* First make sure that the environment variable exists to avoid
373	* doing needless work and to avoid recursion on the unset.
374	*/
375
376	if (index == -1) {
377	Tcl_MutexUnlock(&envMutex);
378	return;
379	}
380	/*
381	* Remember the old value so we can free it if Tcl created the string.
382	*/
383
384	oldValue = environ[index];
385
386	/*
387	* Update the system environment. This must be done before we
388	* update the interpreters or we will recurse.
389	*/
390
391	#ifdef USE_PUTENV
392	string = ckalloc(length+2);
393	memcpy((VOID ) string, (VOID ) name, (size_t) length);
394	string[length] = '=';
395	string[length+1] = '\0';
396
397	Tcl_UtfToExternalDString(NULL, string, -1, &envString);
398	string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
399	strcpy(string, Tcl_DStringValue(&envString));
400	Tcl_DStringFree(&envString);
401
402	putenv(string);
403
404	/*
405	* Watch out for versions of putenv that copy the string (e.g. VC++).
406	* In this case we need to free the string immediately. Otherwise
407	* update the string in the cache.
408	*/
409
410	if (environ[index] == string) {
411	ReplaceString(oldValue, string);
412	}
413	#else
414	for (envPtr = environ+index+1; ; envPtr++) {
415	envPtr[-1] = *envPtr;
416	if (*envPtr == NULL) {
417	break;
418	}
419	}
420	ReplaceString(oldValue, NULL);
421	#endif
422
423	Tcl_MutexUnlock(&envMutex);
424	}
425
426	/*
427	*---------------------------------------------------------------------------
428	*
429	* TclGetEnv --
430	*
431	* Retrieve the value of an environment variable.
432	*
433	* Results:
434	* The result is a pointer to a string specifying the value of the
435	* environment variable, or NULL if that environment variable does
436	* not exist. Storage for the result string is allocated in valuePtr;
437	* the caller must call Tcl_DStringFree() when the result is no
438	* longer needed.
439	*
440	* Side effects:
441	* None.
442	*
443	*----------------------------------------------------------------------
444	*/
445
446	char *
447	TclGetEnv(name, valuePtr)
448	CONST char name; / Name of environment variable to find
449	* (UTF-8). */
450	Tcl_DString valuePtr; / Uninitialized or free DString in which
451	* the value of the environment variable is
452	* stored. */
453	{
454	int length, index;
455	char *result;
456
457	Tcl_MutexLock(&envMutex);
458	index = TclpFindVariable(name, &length);
459	result = NULL;
460	if (index != -1) {
461	Tcl_DString envStr;
462
463	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
464	result += length;
465	if (*result == '=') {
466	result++;
467	Tcl_DStringInit(valuePtr);
468	Tcl_DStringAppend(valuePtr, result, -1);
469	result = Tcl_DStringValue(valuePtr);
470	} else {
471	result = NULL;
472	}
473	Tcl_DStringFree(&envStr);
474	}
475	Tcl_MutexUnlock(&envMutex);
476	return result;
477	}
478
479	/*
480	*----------------------------------------------------------------------
481	*
482	* EnvTraceProc --
483	*
484	* This procedure is invoked whenever an environment variable
485	* is read, modified or deleted. It propagates the change to the global
486	* "environ" array.
487	*
488	* Results:
489	* Always returns NULL to indicate success.
490	*
491	* Side effects:
492	* Environment variable changes get propagated. If the whole
493	* "env" array is deleted, then we stop managing things for
494	* this interpreter (usually this happens because the whole
495	* interpreter is being deleted).
496	*
497	*----------------------------------------------------------------------
498	*/
499
500	/* ARGSUSED */
501	static char *
502	EnvTraceProc(clientData, interp, name1, name2, flags)
503	ClientData clientData; /* Not used. */
504	Tcl_Interp interp; / Interpreter whose "env" variable is
505	* being modified. */
506	char name1; / Better be "env". */
507	char name2; / Name of variable being modified, or NULL
508	* if whole array is being deleted (UTF-8). */
509	int flags; /* Indicates what's happening. */
510	{
511	/*
512	* For array traces, let TclSetupEnv do all the work.
513	*/
514
515	if (flags & TCL_TRACE_ARRAY) {
516	TclSetupEnv(interp);
517	return NULL;
518	}
519
520	/*
521	* If name2 is NULL, then return and do nothing.
522	*/
523
524	if (name2 == NULL) {
525	return NULL;
526	}
527
528	/*
529	* If a value is being set, call TclSetEnv to do all of the work.
530	*/
531
532	if (flags & TCL_TRACE_WRITES) {
533	char *value;
534
535	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
536	TclSetEnv(name2, value);
537	}
538
539	/*
540	* If a value is being read, call TclGetEnv to do all of the work.
541	*/
542
543	if (flags & TCL_TRACE_READS) {
544	Tcl_DString valueString;
545	char *value;
546
547	value = TclGetEnv(name2, &valueString);
548	if (value == NULL) {
549	return "no such variable";
550	}
551	Tcl_SetVar2(interp, name1, name2, value, 0);
552	Tcl_DStringFree(&valueString);
553	}
554
555	/*
556	* For unset traces, let TclUnsetEnv do all the work.
557	*/
558
559	if (flags & TCL_TRACE_UNSETS) {
560	TclUnsetEnv(name2);
561	}
562	return NULL;
563	}
564
565	/*
566	*----------------------------------------------------------------------
567	*
568	* ReplaceString --
569	*
570	* Replace one string with another in the environment variable
571	* cache. The cache keeps track of all of the environment
572	* variables that Tcl has modified so they can be freed later.
573	*
574	* Results:
575	* None.
576	*
577	* Side effects:
578	* May free the old string.
579	*
580	*----------------------------------------------------------------------
581	*/
582
583	static void
584	ReplaceString(oldStr, newStr)
585	CONST char oldStr; / Old environment string. */
586	char newStr; / New environment string. */
587	{
588	int i;
589	char **newCache;
590
591	/*
592	* Check to see if the old value was allocated by Tcl. If so,
593	* it needs to be deallocated to avoid memory leaks. Note that this
594	* algorithm is O(n), not O(1). This will result in n-squared behavior
595	* if lots of environment changes are being made.
596	*/
597
598	for (i = 0; i < cacheSize; i++) {
599	if ((environCache[i] == oldStr) \|\| (environCache[i] == NULL)) {
600	break;
601	}
602	}
603	if (i < cacheSize) {
604	/*
605	* Replace or delete the old value.
606	*/
607
608	if (environCache[i]) {
609	ckfree(environCache[i]);
610	}
611
612	if (newStr) {
613	environCache[i] = newStr;
614	} else {
615	for (; i < cacheSize-1; i++) {
616	environCache[i] = environCache[i+1];
617	}
618	environCache[cacheSize-1] = NULL;
619	}
620	} else {
621	int allocatedSize = (cacheSize + 5) * sizeof(char *);
622
623	/*
624	* We need to grow the cache in order to hold the new string.
625	*/
626
627	newCache = (char **) ckalloc((unsigned) allocatedSize);
628	(VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
629
630	if (environCache) {
631	memcpy((VOID ) newCache, (VOID ) environCache,
632	(size_t) (cacheSize * sizeof(char*)));
633	ckfree((char *) environCache);
634	}
635	environCache = newCache;
636	environCache[cacheSize] = (char *) newStr;
637	environCache[cacheSize+1] = NULL;
638	cacheSize += 5;
639	}
640	}
641
642	/*
643	*----------------------------------------------------------------------
644	*
645	* TclFinalizeEnvironment --
646	*
647	* This function releases any storage allocated by this module
648	* that isn't still in use by the global environment. Any
649	* strings that are still in the environment will be leaked.
650	*
651	* Results:
652	* None.
653	*
654	* Side effects:
655	* May deallocate storage.
656	*
657	*----------------------------------------------------------------------
658	*/
659
660	void
661	TclFinalizeEnvironment()
662	{
663	/*
664	* For now we just deallocate the cache array and none of the environment
665	* strings. This may leak more memory that strictly necessary, since some
666	* of the strings may no longer be in the environment. However,
667	* determining which ones are ok to delete is n-squared, and is pretty
668	* unlikely, so we don't bother.
669	*/
670
671	if (environCache) {
672	ckfree((char *) environCache);
673	environCache = NULL;
674	cacheSize = 0;
675	#ifndef USE_PUTENV
676	environSize = 0;
677	#endif
678	}
679	}
680
681	/* End of tclenv.c */