shared/tcl_base/tclenv.c

/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclenv.c,v 1.1.1.1 2001/06/13 04:37:55 dtashley Exp $ */

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


/* $History: tclenv.c $
 * 
 * *****************  Version 1  *****************
 * User: Dtashley     Date: 1/02/01    Time: 1:26a
 * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
 * Initial check-in.
 */ 

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