/[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 44 - (show annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (8 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 18816 byte(s)
Rename for reorganization.
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 */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25