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	dashley	71	/* $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 */