| 1 |
/* $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 |
length*sizeof(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 */ |
Parent Directory
| 
Revision Log