/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclenv.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclenv.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25