util/src/TclTk/tcl8.6.12/generic/tclEnv.c

   1 /*
   2  * tclEnv.c --
   3  *
   4  *      Tcl support for environment variables, including a setenv function.
   5  *      This file contains the generic portion of the environment module. It
   6  *      is primarily responsible for keeping the "env" arrays in sync with the
   7  *      system environment variables.
   8  *
   9  * Copyright (c) 1991-1994 The Regents of the University of California.
  10  * Copyright (c) 1994-1998 Sun Microsystems, Inc.
  11  *
  12  * See the file "license.terms" for information on usage and redistribution of
  13  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14  */
  15
  16 #include "tclInt.h"
  17
  18 TCL_DECLARE_MUTEX(envMutex)     /* To serialize access to environ. */
  19
  20 #if defined(_WIN32)
  21 #  define tenviron _wenviron
  22 #  define tenviron2utfdstr(tenvstr, len, dstr) \
  23                 Tcl_WinTCharToUtf((TCHAR *)tenvstr, len, dstr)
  24 #  define utf2tenvirondstr(str, len, dstr) \
  25                 (const WCHAR *)Tcl_WinUtfToTChar(str, len, dstr)
  26 #  define techar WCHAR
  27 #  ifdef USE_PUTENV
  28 #    define putenv(env) _wputenv((const wchar_t *)env)
  29 #  endif
  30 #else
  31 #  define tenviron environ
  32 #  define tenviron2utfdstr(tenvstr, len, dstr) \
  33                 Tcl_ExternalToUtfDString(NULL, tenvstr, len, dstr)
  34 #  define utf2tenvirondstr(str, len, dstr) \
  35                 Tcl_UtfToExternalDString(NULL, str, len, dstr)
  36 #  define techar char
  37 #endif
  38
  39
  40 /* MODULE_SCOPE */
  41 size_t TclEnvEpoch = 0; /* Epoch of the tcl environment
  42                                  * (if changed with tcl-env). */
  43
  44 static struct {
  45     int cacheSize;              /* Number of env strings in cache. */
  46     char **cache;               /* Array containing all of the environment
  47                                  * strings that Tcl has allocated. */
  48 #ifndef USE_PUTENV
  49     techar **ourEnviron;                /* Cache of the array that we allocate. We
  50                                  * need to track this in case another
  51                                  * subsystem swaps around the environ array
  52                                  * like we do. */
  53     int ourEnvironSize;         /* Non-zero means that the environ array was
  54                                  * malloced and has this many total entries
  55                                  * allocated to it (not all may be in use at
  56                                  * once). Zero means that the environment
  57                                  * array is in its original static state. */
  58 #endif
  59 } env;
  60
  61 #define tNTL sizeof(techar)
  62
  63 /*
  64  * Declarations for local functions defined in this file:
  65  */
  66
  67 static char *           EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
  68                             const char *name1, const char *name2, int flags);
  69 static void             ReplaceString(const char *oldStr, char *newStr);
  70 MODULE_SCOPE void       TclSetEnv(const char *name, const char *value);
  71 MODULE_SCOPE void       TclUnsetEnv(const char *name);
  72 \f
  73 /*
  74  *----------------------------------------------------------------------
  75  *
  76  * TclSetupEnv --
  77  *
  78  *      This function is invoked for an interpreter to make environment
  79  *      variables accessible from that interpreter via the "env" associative
  80  *      array.
  81  *
  82  * Results:
  83  *      None.
  84  *
  85  * Side effects:
  86  *      The interpreter is added to a list of interpreters managed by us, so
  87  *      that its view of envariables can be kept consistent with the view in
  88  *      other interpreters. If this is the first call to TclSetupEnv, then
  89  *      additional initialization happens, such as copying the environment to
  90  *      dynamically-allocated space for ease of management.
  91  *
  92  *----------------------------------------------------------------------
  93  */
  94
  95 void
  96 TclSetupEnv(
  97     Tcl_Interp *interp)         /* Interpreter whose "env" array is to be
  98                                  * managed. */
  99 {
 100     Var *varPtr, *arrayPtr;
 101     Tcl_Obj *varNamePtr;
 102     Tcl_DString envString;
 103     Tcl_HashTable namesHash;
 104     Tcl_HashEntry *hPtr;
 105     Tcl_HashSearch search;
 106
 107     /*
 108      * Synchronize the values in the environ array with the contents of the
 109      * Tcl "env" variable. To do this:
 110      *    1) Remove the trace that fires when the "env" var is updated.
 111      *    2) Find the existing contents of the "env", storing in a hash table.
 112      *    3) Create/update elements for each environ variable, removing
 113      *       elements from the hash table as we go.
 114      *    4) Remove the elements for each remaining entry in the hash table,
 115      *       which must have existed before yet have no analog in the environ
 116      *       variable.
 117      *    5) Add a trace that synchronizes the "env" array.
 118      */
 119
 120     Tcl_UntraceVar2(interp, "env", NULL,
 121             TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
 122             TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
 123
 124     /*
 125      * Find out what elements are currently in the global env array.
 126      */
 127
 128     TclNewLiteralStringObj(varNamePtr, "env");
 129     Tcl_IncrRefCount(varNamePtr);
 130     Tcl_InitObjHashTable(&namesHash);
 131     varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
 132             /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
 133     TclFindArrayPtrElements(varPtr, &namesHash);
 134
 135 #if defined(_WIN32)
 136     if (tenviron == NULL) {
 137         /*
 138          * When we are started from main(), the _wenviron array could
 139          * be NULL and will be initialized by the first _wgetenv() call.
 140          */
 141
 142         (void) _wgetenv(L"WINDIR");
 143     }
 144 #endif
 145
 146     /*
 147      * Go through the environment array and transfer its values into Tcl. At
 148      * the same time, remove those elements we add/update from the hash table
 149      * of existing elements, so that after this part processes, that table
 150      * will hold just the parts to remove.
 151      */
 152
 153     if (tenviron[0] != NULL) {
 154         int i;
 155
 156         Tcl_MutexLock(&envMutex);
 157         for (i = 0; tenviron[i] != NULL; i++) {
 158             Tcl_Obj *obj1, *obj2;
 159             const char *p1;
 160             char *p2;
 161
 162             p1 = tenviron2utfdstr(tenviron[i], -1, &envString);
 163             p2 = (char *)strchr(p1, '=');
 164             if (p2 == NULL) {
 165                 /*
 166                  * This condition seem to happen occasionally under some
 167                  * versions of Solaris, or when encoding accidents swallow the
 168                  * '='; ignore the entry.
 169                  */
 170
 171                 Tcl_DStringFree(&envString);
 172                 continue;
 173             }
 174             p2++;
 175             p2[-1] = '\0';
 176 #if defined(_WIN32)
 177             /*
 178              * Enforce PATH and COMSPEC to be all uppercase. This eliminates
 179              * additional trace logic otherwise required in init.tcl.
 180              */
 181
 182             if (strcasecmp(p1, "PATH") == 0) {
 183                 p1 = "PATH";
 184             } else if (strcasecmp(p1, "COMSPEC") == 0) {
 185                 p1 = "COMSPEC";
 186             }
 187 #endif
 188             obj1 = Tcl_NewStringObj(p1, -1);
 189             obj2 = Tcl_NewStringObj(p2, -1);
 190             Tcl_DStringFree(&envString);
 191
 192             Tcl_IncrRefCount(obj1);
 193             Tcl_IncrRefCount(obj2);
 194             Tcl_ObjSetVar2(interp, varNamePtr, obj1, obj2, TCL_GLOBAL_ONLY);
 195             hPtr = Tcl_FindHashEntry(&namesHash, obj1);
 196             if (hPtr != NULL) {
 197                 Tcl_DeleteHashEntry(hPtr);
 198             }
 199             Tcl_DecrRefCount(obj1);
 200             Tcl_DecrRefCount(obj2);
 201         }
 202         Tcl_MutexUnlock(&envMutex);
 203     }
 204
 205     /*
 206      * Delete those elements that existed in the array but which had no
 207      * counterparts in the environment array.
 208      */
 209
 210     for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
 211             hPtr=Tcl_NextHashEntry(&search)) {
 212         Tcl_Obj *elemName = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
 213
 214         TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
 215     }
 216     Tcl_DeleteHashTable(&namesHash);
 217     Tcl_DecrRefCount(varNamePtr);
 218
 219     /*
 220      * Re-establish the trace.
 221      */
 222
 223     Tcl_TraceVar2(interp, "env", NULL,
 224             TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
 225             TCL_TRACE_READS | TCL_TRACE_ARRAY, EnvTraceProc, NULL);
 226 }
 227 \f
 228 /*
 229  *----------------------------------------------------------------------
 230  *
 231  * TclSetEnv --
 232  *
 233  *      Set an environment variable, replacing an existing value or creating a
 234  *      new variable if there doesn't exist a variable by the given name. This
 235  *      function is intended to be a stand-in for the UNIX "setenv" function
 236  *      so that applications using that function will interface properly to
 237  *      Tcl. To make it a stand-in, the Makefile must define "TclSetEnv" to
 238  *      "setenv".
 239  *
 240  * Results:
 241  *      None.
 242  *
 243  * Side effects:
 244  *      The environ array gets updated.
 245  *
 246  *----------------------------------------------------------------------
 247  */
 248
 249 void
 250 TclSetEnv(
 251     const char *name,           /* Name of variable whose value is to be set
 252                                  * (UTF-8). */
 253     const char *value)          /* New value for variable (UTF-8). */
 254 {
 255     Tcl_DString envString;
 256     unsigned nameLength, valueLength;
 257     int index, length;
 258     char *p, *oldValue;
 259     const techar *p2;
 260
 261     /*
 262      * Figure out where the entry is going to go. If the name doesn't already
 263      * exist, enlarge the array if necessary to make room. If the name exists,
 264      * free its old entry.
 265      */
 266
 267     Tcl_MutexLock(&envMutex);
 268     index = TclpFindVariable(name, &length);
 269
 270     if (index == -1) {
 271 #ifndef USE_PUTENV
 272         /*
 273          * We need to handle the case where the environment may be changed
 274          * outside our control. ourEnvironSize is only valid if the current
 275          * environment is the one we allocated. [Bug 979640]
 276          */
 277
 278         if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) {
 279             techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *));
 280
 281             memcpy(newEnviron, tenviron, length * sizeof(techar *));
 282             if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
 283                 ckfree(env.ourEnviron);
 284             }
 285             tenviron = (env.ourEnviron = newEnviron);
 286             env.ourEnvironSize = length + 5;
 287         }
 288         index = length;
 289         tenviron[index + 1] = NULL;
 290 #endif /* USE_PUTENV */
 291         oldValue = NULL;
 292         nameLength = strlen(name);
 293     } else {
 294         const char *oldEnv;
 295
 296         /*
 297          * Compare the new value to the existing value. If they're the same
 298          * then quit immediately (e.g. don't rewrite the value or propagate it
 299          * to other interpreters). Otherwise, when there are N interpreters
 300          * there will be N! propagations of the same value among the
 301          * interpreters.
 302          */
 303
 304         oldEnv = tenviron2utfdstr(tenviron[index], -1, &envString);
 305         if (strcmp(value, oldEnv + (length + 1)) == 0) {
 306             Tcl_DStringFree(&envString);
 307             Tcl_MutexUnlock(&envMutex);
 308             return;
 309         }
 310         Tcl_DStringFree(&envString);
 311
 312         oldValue = (char *)tenviron[index];
 313         nameLength = length;
 314     }
 315
 316     /*
 317      * Create a new entry. Build a complete UTF string that contains a
 318      * "name=value" pattern. Then convert the string to the native encoding,
 319      * and set the environ array value.
 320      */
 321
 322     valueLength = strlen(value);
 323     p = (char *)ckalloc(nameLength + valueLength + 2);
 324     memcpy(p, name, nameLength);
 325     p[nameLength] = '=';
 326     memcpy(p+nameLength+1, value, valueLength+1);
 327     p2 = utf2tenvirondstr(p, -1, &envString);
 328
 329     /*
 330      * Copy the native string to heap memory.
 331      */
 332
 333     p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL);
 334     memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL);
 335     Tcl_DStringFree(&envString);
 336
 337 #ifdef USE_PUTENV
 338     /*
 339      * Update the system environment.
 340      */
 341
 342     putenv(p);
 343     index = TclpFindVariable(name, &length);
 344 #else
 345     tenviron[index] = (techar *)p;
 346 #endif /* USE_PUTENV */
 347
 348     /*
 349      * Watch out for versions of putenv that copy the string (e.g. VC++). In
 350      * this case we need to free the string immediately. Otherwise update the
 351      * string in the cache.
 352      */
 353
 354     if ((index != -1) && (tenviron[index] == (techar *)p)) {
 355         ReplaceString(oldValue, p);
 356 #ifdef HAVE_PUTENV_THAT_COPIES
 357     } else {
 358         /*
 359          * This putenv() copies instead of taking ownership.
 360          */
 361
 362         ckfree(p);
 363 #endif /* HAVE_PUTENV_THAT_COPIES */
 364     }
 365
 366     Tcl_MutexUnlock(&envMutex);
 367
 368     if (!strcmp(name, "HOME")) {
 369         /*
 370          * If the user's home directory has changed, we must invalidate the
 371          * filesystem cache, because '~' expansions will now be incorrect.
 372          */
 373
 374         Tcl_FSMountsChanged(NULL);
 375     }
 376 }
 377 \f
 378 /*
 379  *----------------------------------------------------------------------
 380  *
 381  * Tcl_PutEnv --
 382  *
 383  *      Set an environment variable. Similar to setenv except that the
 384  *      information is passed in a single string of the form NAME=value,
 385  *      rather than as separate name strings. This function is intended to be
 386  *      a stand-in for the UNIX "putenv" function so that applications using
 387  *      that function will interface properly to Tcl. To make it a stand-in,
 388  *      the Makefile will define "Tcl_PutEnv" to "putenv".
 389  *
 390  * Results:
 391  *      None.
 392  *
 393  * Side effects:
 394  *      The environ array gets updated, as do all of the interpreters that we
 395  *      manage.
 396  *
 397  *----------------------------------------------------------------------
 398  */
 399
 400 int
 401 Tcl_PutEnv(
 402     const char *assignment)     /* Info about environment variable in the form
 403                                  * NAME=value. (native) */
 404 {
 405     Tcl_DString nameString;
 406     const char *name;
 407     char *value;
 408
 409     if (assignment == NULL) {
 410         return 0;
 411     }
 412
 413     /*
 414      * First convert the native string to UTF. Then separate the string into
 415      * name and value parts, and call TclSetEnv to do all of the real work.
 416      */
 417
 418     name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
 419     value = (char *)strchr(name, '=');
 420
 421     if ((value != NULL) && (value != name)) {
 422         value[0] = '\0';
 423 #if defined(_WIN32)
 424         if (tenviron == NULL) {
 425             /*
 426              * When we are started from main(), the _wenviron array could
 427              * be NULL and will be initialized by the first _wgetenv() call.
 428              */
 429
 430         (void) _wgetenv(L"WINDIR");
 431         }
 432 #endif
 433         TclSetEnv(name, value+1);
 434     }
 435     TclEnvEpoch++;
 436
 437     Tcl_DStringFree(&nameString);
 438     return 0;
 439 }
 440 \f
 441 /*
 442  *----------------------------------------------------------------------
 443  *
 444  * TclUnsetEnv --
 445  *
 446  *      Remove an environment variable, updating the "env" arrays in all
 447  *      interpreters managed by us. This function is intended to replace the
 448  *      UNIX "unsetenv" function (but to do this the Makefile must be modified
 449  *      to redefine "TclUnsetEnv" to "unsetenv".
 450  *
 451  * Results:
 452  *      None.
 453  *
 454  * Side effects:
 455  *      Interpreters are updated, as is environ.
 456  *
 457  *----------------------------------------------------------------------
 458  */
 459
 460 void
 461 TclUnsetEnv(
 462     const char *name)           /* Name of variable to remove (UTF-8). */
 463 {
 464     char *oldValue;
 465     int length;
 466     int index;
 467 #ifdef USE_PUTENV_FOR_UNSET
 468     Tcl_DString envString;
 469     char *string;
 470 #else
 471     char **envPtr;
 472 #endif /* USE_PUTENV_FOR_UNSET */
 473
 474     Tcl_MutexLock(&envMutex);
 475     index = TclpFindVariable(name, &length);
 476
 477     /*
 478      * First make sure that the environment variable exists to avoid doing
 479      * needless work and to avoid recursion on the unset.
 480      */
 481
 482     if (index == -1) {
 483         Tcl_MutexUnlock(&envMutex);
 484         return;
 485     }
 486
 487     /*
 488      * Remember the old value so we can free it if Tcl created the string.
 489      */
 490
 491     oldValue = (char *)tenviron[index];
 492
 493     /*
 494      * Update the system environment. This must be done before we update the
 495      * interpreters or we will recurse.
 496      */
 497
 498 #ifdef USE_PUTENV_FOR_UNSET
 499     /*
 500      * For those platforms that support putenv to unset, Linux indicates
 501      * that no = should be included, and Windows requires it.
 502      */
 503
 504 #if defined(_WIN32)
 505     string = (char *)ckalloc(length + 2);
 506     memcpy(string, name, length);
 507     string[length] = '=';
 508     string[length+1] = '\0';
 509 #else
 510     string = (char *)ckalloc(length + 1);
 511     memcpy(string, name, length);
 512     string[length] = '\0';
 513 #endif /* _WIN32 */
 514
 515     utf2tenvirondstr(string, -1, &envString);
 516     string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL);
 517     memcpy(string, Tcl_DStringValue(&envString),
 518             Tcl_DStringLength(&envString) + tNTL);
 519     Tcl_DStringFree(&envString);
 520
 521     putenv(string);
 522
 523     /*
 524      * Watch out for versions of putenv that copy the string (e.g. VC++). In
 525      * this case we need to free the string immediately. Otherwise update the
 526      * string in the cache.
 527      */
 528
 529     if (tenviron[index] == (techar *)string) {
 530         ReplaceString(oldValue, string);
 531 #ifdef HAVE_PUTENV_THAT_COPIES
 532     } else {
 533         /*
 534          * This putenv() copies instead of taking ownership.
 535          */
 536
 537         ckfree(string);
 538 #endif /* HAVE_PUTENV_THAT_COPIES */
 539     }
 540 #else /* !USE_PUTENV_FOR_UNSET */
 541     for (envPtr = (char **)(tenviron+index+1); ; envPtr++) {
 542         envPtr[-1] = *envPtr;
 543         if (*envPtr == NULL) {
 544             break;
 545         }
 546     }
 547     ReplaceString(oldValue, NULL);
 548 #endif /* USE_PUTENV_FOR_UNSET */
 549
 550     Tcl_MutexUnlock(&envMutex);
 551 }
 552 \f
 553 /*
 554  *---------------------------------------------------------------------------
 555  *
 556  * TclGetEnv --
 557  *
 558  *      Retrieve the value of an environment variable.
 559  *
 560  * Results:
 561  *      The result is a pointer to a string specifying the value of the
 562  *      environment variable, or NULL if that environment variable does not
 563  *      exist. Storage for the result string is allocated in valuePtr; the
 564  *      caller must call Tcl_DStringFree() when the result is no longer
 565  *      needed.
 566  *
 567  * Side effects:
 568  *      None.
 569  *
 570  *----------------------------------------------------------------------
 571  */
 572
 573 const char *
 574 TclGetEnv(
 575     const char *name,           /* Name of environment variable to find
 576                                  * (UTF-8). */
 577     Tcl_DString *valuePtr)      /* Uninitialized or free DString in which the
 578                                  * value of the environment variable is
 579                                  * stored. */
 580 {
 581     int length, index;
 582     const char *result;
 583
 584     Tcl_MutexLock(&envMutex);
 585     index = TclpFindVariable(name, &length);
 586     result = NULL;
 587     if (index != -1) {
 588         Tcl_DString envStr;
 589
 590         result = tenviron2utfdstr(tenviron[index], -1, &envStr);
 591         result += length;
 592         if (*result == '=') {
 593             result++;
 594             Tcl_DStringInit(valuePtr);
 595             Tcl_DStringAppend(valuePtr, result, -1);
 596             result = Tcl_DStringValue(valuePtr);
 597         } else {
 598             result = NULL;
 599         }
 600         Tcl_DStringFree(&envStr);
 601     }
 602     Tcl_MutexUnlock(&envMutex);
 603     return result;
 604 }
 605 \f
 606 /*
 607  *----------------------------------------------------------------------
 608  *
 609  * EnvTraceProc --
 610  *
 611  *      This function is invoked whenever an environment variable is read,
 612  *      modified or deleted. It propagates the change to the global "environ"
 613  *      array.
 614  *
 615  * Results:
 616  *      Returns NULL to indicate success, or an error-message if the array
 617  *      element being handled doesn't exist.
 618  *
 619  * Side effects:
 620  *      Environment variable changes get propagated. If the whole "env" array
 621  *      is deleted, then we stop managing things for this interpreter (usually
 622  *      this happens because the whole interpreter is being deleted).
 623  *
 624  *----------------------------------------------------------------------
 625  */
 626
 627         /* ARGSUSED */
 628 static char *
 629 EnvTraceProc(
 630     ClientData clientData,      /* Not used. */
 631     Tcl_Interp *interp,         /* Interpreter whose "env" variable is being
 632                                  * modified. */
 633     const char *name1,          /* Better be "env". */
 634     const char *name2,          /* Name of variable being modified, or NULL if
 635                                  * whole array is being deleted (UTF-8). */
 636     int flags)                  /* Indicates what's happening. */
 637 {
 638     /*
 639      * For array traces, let TclSetupEnv do all the work.
 640      */
 641
 642     if (flags & TCL_TRACE_ARRAY) {
 643         TclSetupEnv(interp);
 644         TclEnvEpoch++;
 645         return NULL;
 646     }
 647
 648     /*
 649      * If name2 is NULL, then return and do nothing.
 650      */
 651
 652     if (name2 == NULL) {
 653         return NULL;
 654     }
 655
 656     /*
 657      * If a value is being set, call TclSetEnv to do all of the work.
 658      */
 659
 660     if (flags & TCL_TRACE_WRITES) {
 661         const char *value;
 662
 663         value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
 664         TclSetEnv(name2, value);
 665         TclEnvEpoch++;
 666     }
 667
 668     /*
 669      * If a value is being read, call TclGetEnv to do all of the work.
 670      */
 671
 672     if (flags & TCL_TRACE_READS) {
 673         Tcl_DString valueString;
 674         const char *value = TclGetEnv(name2, &valueString);
 675
 676         if (value == NULL) {
 677             return (char *) "no such variable";
 678         }
 679         Tcl_SetVar2(interp, name1, name2, value, 0);
 680         Tcl_DStringFree(&valueString);
 681     }
 682
 683     /*
 684      * For unset traces, let TclUnsetEnv do all the work.
 685      */
 686
 687     if (flags & TCL_TRACE_UNSETS) {
 688         TclUnsetEnv(name2);
 689         TclEnvEpoch++;
 690     }
 691     return NULL;
 692 }
 693 \f
 694 /*
 695  *----------------------------------------------------------------------
 696  *
 697  * ReplaceString --
 698  *
 699  *      Replace one string with another in the environment variable cache. The
 700  *      cache keeps track of all of the environment variables that Tcl has
 701  *      modified so they can be freed later.
 702  *
 703  * Results:
 704  *      None.
 705  *
 706  * Side effects:
 707  *      May free the old string.
 708  *
 709  *----------------------------------------------------------------------
 710  */
 711
 712 static void
 713 ReplaceString(
 714     const char *oldStr,         /* Old environment string. */
 715     char *newStr)               /* New environment string. */
 716 {
 717     int i;
 718
 719     /*
 720      * Check to see if the old value was allocated by Tcl. If so, it needs to
 721      * be deallocated to avoid memory leaks. Note that this algorithm is O(n),
 722      * not O(1). This will result in n-squared behavior if lots of environment
 723      * changes are being made.
 724      */
 725
 726     for (i = 0; i < env.cacheSize; i++) {
 727         if (env.cache[i]==oldStr || env.cache[i]==NULL) {
 728             break;
 729         }
 730     }
 731     if (i < env.cacheSize) {
 732         /*
 733          * Replace or delete the old value.
 734          */
 735
 736         if (env.cache[i]) {
 737             ckfree(env.cache[i]);
 738         }
 739
 740         if (newStr) {
 741             env.cache[i] = newStr;
 742         } else {
 743             for (; i < env.cacheSize-1; i++) {
 744                 env.cache[i] = env.cache[i+1];
 745             }
 746             env.cache[env.cacheSize-1] = NULL;
 747         }
 748     } else {
 749         /*
 750          * We need to grow the cache in order to hold the new string.
 751          */
 752
 753         const int growth = 5;
 754
 755         env.cache = (char **)ckrealloc(env.cache,
 756                 (env.cacheSize + growth) * sizeof(char *));
 757         env.cache[env.cacheSize] = newStr;
 758         (void) memset(env.cache+env.cacheSize+1, 0,
 759                 (size_t) (growth-1) * sizeof(char *));
 760         env.cacheSize += growth;
 761     }
 762 }
 763 \f
 764 /*
 765  *----------------------------------------------------------------------
 766  *
 767  * TclFinalizeEnvironment --
 768  *
 769  *      This function releases any storage allocated by this module that isn't
 770  *      still in use by the global environment. Any strings that are still in
 771  *      the environment will be leaked.
 772  *
 773  * Results:
 774  *      None.
 775  *
 776  * Side effects:
 777  *      May deallocate storage.
 778  *
 779  *----------------------------------------------------------------------
 780  */
 781
 782 void
 783 TclFinalizeEnvironment(void)
 784 {
 785     /*
 786      * For now we just deallocate the cache array and none of the environment
 787      * strings. This may leak more memory that strictly necessary, since some
 788      * of the strings may no longer be in the environment. However,
 789      * determining which ones are ok to delete is n-squared, and is pretty
 790      * unlikely, so we don't bother.  However, in the case of DPURIFY, just
 791      * free all strings in the cache.
 792      */
 793
 794     if (env.cache) {
 795 #ifdef PURIFY
 796         int i;
 797         for (i = 0; i < env.cacheSize; i++) {
 798             ckfree(env.cache[i]);
 799         }
 800 #endif
 801         ckfree(env.cache);
 802         env.cache = NULL;
 803         env.cacheSize = 0;
 804 #ifndef USE_PUTENV
 805         if ((env.ourEnviron != NULL)) {
 806             ckfree(env.ourEnviron);
 807             env.ourEnviron = NULL;
 808         }
 809         env.ourEnvironSize = 0;
 810 #endif
 811     }
 812 }
 813 \f
 814 /*
 815  * Local Variables:
 816  * mode: c
 817  * c-basic-offset: 4
 818  * fill-column: 78
 819  * End:
 820  */