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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 29 - (hide annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (7 years, 9 months ago) by dashley
Original Path: to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclenv.c
File MIME type: text/plain
File size: 18816 byte(s)
Directories relocated.
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     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