/[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 64 - (hide annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 8 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 dashley 64 /* $Header$ */
2 dashley 25 /*
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 dashley 64 /* End of tclenv.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25