Tcl Source Code

Check-in [9aa06360d3]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:
* generic/tclVar.c: * generic/tclEnv.c: Moved the "array set" C level code into a common routine (TclArraySet). The TclSetupEnv routine now uses this API to create an env array w/ no elements.
* generic/tclEnv.c: * generic/tclWinInit.h: * generic/tclUnixInit.h: * generic/tclInt.h: Made the Env module I18N compliant. Changed the FindVariable routine to TclpFindVariable, that now does a case insensitive string comparison on Windows, and not on UNIX. [Bug: 1299, 1500]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1:9aa06360d3d689bb265ee5c3508f4d4f03fc24c2
User & Date: surles 1999-04-06 19:06:50
Context
1999-04-06
19:19
unchange the makefile.vc check-in: d0c3b3bdcb user: surles tags: core-8-1-branch-old
19:06
* generic/tclVar.c: * generic/tclEnv.c: Moved the "array set" C level code into a common routine ...
check-in: 9aa06360d3 user: surles tags: core-8-1-branch-old
19:03
skip tests that require test* commands when running in standard tclsh interp. check-in: 1467d41628 user: hershey tags: core-8-1-branch-old
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.
















1
2
3
4
5
6
7














1999-04-05    <[email protected]>

	* tests/io.test: Minor test cleanup.

	* generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make
	it easier to compile on Digital-unix. [Bug: 1659]

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
1999-04-06    <[email protected]>

	* generic/tclVar.c: 
	* generic/tclEnv.c: Moved the "array set" C level code into a
	common routine (TclArraySet).  The TclSetupEnv routine now uses
	this API to create an env array w/ no elements.

	* generic/tclEnv.c:
	* generic/tclWinInit.h:
	* generic/tclUnixInit.h:
	* generic/tclInt.h: Made the Env module I18N compliant.  Changed the
	FindVariable routine to TclpFindVariable, that now does a case
	insensitive string comparison on Windows, and not on UNIX. [Bug:
	1299, 1500]

1999-04-05    <[email protected]>

	* tests/io.test: Minor test cleanup.

	* generic/tclEncoding.c (Tcl_CreateEncoding): Minor lint to make
	it easier to compile on Digital-unix. [Bug: 1659]

Changes to changes.

1
2
3
4
5
6
7
8
9
10
....
4286
4287
4288
4289
4290
4291
4292














4293
4294
4295
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.1.2.27 1999/04/06 05:50:26 welch Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return
................................................................................
(redman)

4/5/99 (bug fix) Configure patches to improve support for
OS/390 and BSD/OS 4.*. (stanton)

4/5/99 (bug fix) Fixed crash in the clock command that occurred
with negative time values in timezones east of GMT. (stanton)















--------------- Released 8.1b3, April 6, 1999 ----------------------


|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>



1
2
3
4
5
6
7
8
9
10
....
4286
4287
4288
4289
4290
4291
4292
4293
4294
4295
4296
4297
4298
4299
4300
4301
4302
4303
4304
4305
4306
4307
4308
4309
Recent user-visible changes to Tcl:

RCS: @(#) $Id: changes,v 1.1.2.28 1999/04/06 19:06:51 surles Exp $

1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.

2. Semi-colon now available for grouping commands on a line.

3. For a command to span multiple lines, must now use backslash-return
................................................................................
(redman)

4/5/99 (bug fix) Configure patches to improve support for
OS/390 and BSD/OS 4.*. (stanton)

4/5/99 (bug fix) Fixed crash in the clock command that occurred
with negative time values in timezones east of GMT. (stanton)

4/6/99 (bug fix) Moved the "array set" C level code into a common
routine (TclArraySet).  The TclSetupEnv routine now uses this API to
create an env array w/ no elements.  This fixes the bug caused when
every environ varaible is removed, and the Tcl env variable is
synched.  If no environ vars existed, the Tcl env var would never be
created. (surles)

4/6/99 (bug fix) Made the Env module I18N compliant. (surles)

4/6/99 (bug fix) Changed the FindVariable routine to TclpFindVariable,
that now does a case insensitive string comparison on Windows, and not
on UNIX. (surles)


--------------- Released 8.1b3, April 6, 1999 ----------------------

Changes to generic/tclEnv.c.

8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
..
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87




88
89





90
91
92
93
94
95
96

97








98
99
100
101
102
103
104
105
106
107
108
109


110
111
112
113
114
115

116
117
118
119

120
121
122
123
124
125
126
...
138
139
140
141
142
143
144
145
146
147
148

149
150
151
152
153
154
155
156
157
158
159

160
161
162
163
164
165
166
...
174
175
176
177
178
179
180


181
182
183
184
185
186
187
188

189

190
191
192


193
194
195
196
197
198
199


200
201
202
203
204
205


206


207
208
209
210
211
212
213
214






215
216
217
218
219
220
221
222
223
224
225
226
227
228

229
230
231
232
233
234
235
...
253
254
255
256
257
258
259

260
261
262
263
264
265
266
267

268
269
270
271

272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
...
303
304
305
306
307
308
309
310
311
312
313
314

315
316
317
318
319
320
321
322
323
324
325
326
327
328
...
341
342
343
344
345
346
347


348

349












350
351
352
353
354
355
356
357
358
359
360
361
362
363

364
365
366
367
368
369
370
...
390
391
392
393
394
395
396
397
398
399
400
401
402

403
404
405
406
407
408



409






410
411
412
413
414
415
416
...
440
441
442
443
444
445
446

















447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
...
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
...
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.1.2.5 1998/12/12 01:36:56 lfb Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

................................................................................
/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, char *name2,
			    int flags));
static int		FindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));
static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));

 
................................................................................
 */

void
TclSetupEnv(interp)
    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
				 * managed. */
{

    char *p, *p2;
    Tcl_DString nameString, valueString;
    int i;

    /*
     * Store the environment variable values into the interpreter's
     * "env" array, and arrange for us to be notified on future
     * writes and unsets to that array.




     */






    (void) Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY);

    Tcl_MutexLock(&envMutex);
    for (i = 0; ; i++) {
	p = environ[i];
	if (p == NULL) {
	    break;

	}








	p2 = strchr(p, '=');
	if (p2 == NULL) {
	    /*
	     * This condition doesn't seem like it should ever happen,
	     * but it does seem to happen occasionally under some
	     * versions of Solaris; ignore the entry.
	     */

	    continue;
	}
	Tcl_ExternalToUtfDString(NULL, p, p2 - p, &nameString);
	Tcl_ExternalToUtfDString(NULL, p2 + 1, -1, &valueString);


	Tcl_SetVar2(interp, "env", Tcl_DStringValue(&nameString),
                Tcl_DStringValue(&valueString), TCL_GLOBAL_ONLY);
	Tcl_DStringFree(&nameString);
	Tcl_DStringFree(&valueString);
    }
    Tcl_MutexUnlock(&envMutex);


    Tcl_TraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc, (ClientData) NULL);

}
 
/*
 *----------------------------------------------------------------------
 *
 * TclSetEnv --
 *
................................................................................
 *	The environ array gets updated.
 *
 *----------------------------------------------------------------------
 */

void
TclSetEnv(name, value)
    CONST char *name;		/* Nname of variable whose value is to be
				 * set (native). */
    CONST char *value;		/* New value for variable (native). */
{

    int index, length, nameLength;
    char *p, *oldValue;

    /*
     * Figure out where the entry is going to go.  If the name doesn't
     * already exist, enlarge the array if necessary to make room.  If the
     * name exists, free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = FindVariable(name, &length);

    if (index == -1) {
#ifndef USE_PUTENV
	if ((length + 2) > environSize) {
	    char **newEnviron;

	    newEnviron = (char **) ckalloc((unsigned)
		    ((length + 5) * sizeof(char *)));
................................................................................
	}
	index = length;
	environ[index + 1] = NULL;
#endif
	oldValue = NULL;
	nameLength = strlen(name);
    } else {


	/*
	 * Compare the new value to the existing value.  If they're
	 * the same then quit immediately (e.g. don't rewrite the
	 * value or propagate it to other interpreters).  Otherwise,
	 * when there are N interpreters there will be N! propagations
	 * of the same value among the interpreters.
	 */


	if (strcmp(value, environ[index] + length + 1) == 0) {

	    Tcl_MutexUnlock(&envMutex);
	    return;
	}


	oldValue = environ[index];
	nameLength = length;
    }
	

    /*
     * Create a new entry.


     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);





    /*
     * Update the system environment.
     */

#ifdef USE_PUTENV
    putenv(p);
    index = FindVariable(name, &length);
#else






    environ[index] = p;
#endif

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] != p) {
	ckfree(p);
    } else {
	ReplaceString(oldValue, p);
    }

    Tcl_MutexUnlock(&envMutex);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutEnv --
................................................................................
 */

int
Tcl_PutEnv(string)
    CONST char *string;		/* Info about environment variable in the
				 * form NAME=value. (native) */
{

    int nameLength;
    char *name, *value;

    if (string == NULL) {
	return 0;
    }

    /*

     * Separate the string into name and value parts, then call
     * TclSetEnv to do all of the real work.
     */


    value = strchr(string, '=');
    if (value == NULL) {
	return 0;
    }
    nameLength = value - string;
    if (nameLength == 0) {
	return 0;
    }
    name = (char *) ckalloc((unsigned) nameLength+1);
    memcpy((VOID *) name, (VOID *) string, (size_t) nameLength);
    name[nameLength] = 0;
    TclSetEnv(name, value+1);
    ckfree(name);
    return 0;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclUnsetEnv --
................................................................................
 *	Interpreters are updated, as is environ.
 *
 *----------------------------------------------------------------------
 */

void
TclUnsetEnv(name)
    CONST char *name;		/* Name of variable to remove (native). */
{
    char *oldValue;
    int length, index;
#ifdef USE_PUTENV

    char *string;
#else
    char **envPtr;
#endif

    Tcl_MutexLock(&envMutex);
    index = FindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid
     * doing needless work and to avoid recursion on the unset.
     */
    
    if (index == -1) {
................................................................................
     */

#ifdef USE_PUTENV
    string = ckalloc(length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';


    putenv(string);

    ckfree(string);












#else
    for (envPtr = environ+index+1; ; envPtr++) {
	envPtr[-1] = *envPtr;
	if (*envPtr == NULL) {
	    break;
	}
    }
#endif

    /*
     * Replace the old value in the cache.
     */

    ReplaceString(oldValue, NULL);


    Tcl_MutexUnlock(&envMutex);
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    CONST char *name;		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr;	/* Uninitialized or free DString in which
				 * the value of the environment variable is
				 * stored. */
{
    int length, index;
    Tcl_DString nameString;
    char *result;

    Tcl_MutexLock(&envMutex);
    Tcl_UtfToExternalDString(NULL, name, -1, &nameString);


    index = FindVariable(Tcl_DStringValue(&nameString), &length);
    Tcl_DStringFree(&nameString);
    
    result = NULL;
    if ((index != -1) &&  (*(environ[index]+length) == '=')) {
	result = Tcl_ExternalToUtfDString(NULL, environ[index]+length+1,



		-1, valuePtr);






    }
    Tcl_MutexUnlock(&envMutex);
    return result;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    char *name1;		/* Better be "env". */
    char *name2;		/* Name of variable being modified, or NULL
				 * if whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{

















    /*
     * If a value is being set, call TclSetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_WRITES) {
	Tcl_DString nameString, valueString;
	char *value;
	
	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
	Tcl_UtfToExternalDString(NULL, name2, -1, &nameString);
	Tcl_UtfToExternalDString(NULL, value, -1, &valueString);
	TclSetEnv(Tcl_DStringValue(&nameString),
		Tcl_DStringValue(&valueString));
	Tcl_DStringFree(&nameString);
	Tcl_DStringFree(&valueString);
    }

    /*
     * If a value is being read, call TclGetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_READS) {
................................................................................
	value = TclGetEnv(name2, &valueString);
	if (value == NULL) {
	    return "no such variable";
	}
	Tcl_SetVar2(interp, name1, name2, value, 0);
	Tcl_DStringFree(&valueString);
    }

    /*
     * For array traces, let TclSetupEnv do all the work.
     */

    if (flags & TCL_TRACE_ARRAY) {
	TclSetupEnv(interp);
    }


    /*
     * For unset traces, let TclUnsetEnv do all the work.
     */

    if ((flags & TCL_TRACE_UNSETS) && (name2 != NULL)) {
	Tcl_DString nameString;

	Tcl_UtfToExternalDString(NULL, name2, -1, &nameString);
	TclUnsetEnv(Tcl_DStringValue(&nameString));
	Tcl_DStringFree(&nameString);
    }
    return NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	environCache = newCache;
	environCache[cacheSize] = (char *) newStr;
	environCache[cacheSize+1] = NULL;
	cacheSize += 5;
    }
}
 
/*
 *----------------------------------------------------------------------
 *
 * FindVariable --
 *
 *	Locate the entry in environ for a given name.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
FindVariable(name, lengthPtr)
    CONST char *name;		/* Name of desired environment variable
				 * (native). */
    int *lengthPtr;		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i;
    register CONST char *p1, *p2;

    for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
	for (p2 = name; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = p2-name;
	    return i;
	}
    }
    *lengthPtr = i;
    return -1;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEnvironment --
 *
 *	This function releases any storage allocated by this module






|







 







<
<







 







>
|
<



|
|
|
>
>
>
>

|
>
>
>
>
>
|
|
<
<
<
|
<
>
|
>
>
>
>
>
>
>
>
|
|
|
<
|
|
|
|
|
|
<
<
>
>
|
<
|
<
|
|
>



|
>







 







|
|
|

>

|








|
>







 







>
>








>
|
>



>
>






|
>
>






>
>
|
>
>




<
|
|

>
>
>
>
>
>










|



>







 







>








>
|
|


>
|



|



|
|
|
|
<







 







|




>






|







 







>
>
|
>
|
>
>
>
>
>
>
>
>
>
>
>
>







<
<
<
<
<
<

>







 







<



|
<
>
|
|
|
<
<
|
>
>
>
|
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





<



|
<
<
<
<
<







 







<
<
<
<
<
<
<
<
<





|
<
<
<
|
<







 







<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
36
37
38
39
40
41
42


43
44
45
46
47
48
49
..
71
72
73
74
75
76
77
78
79

80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98



99

100
101
102
103
104
105
106
107
108
109
110
111
112

113
114
115
116
117
118


119
120
121

122

123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
...
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
...
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235

236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
...
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317

318
319
320
321
322
323
324
...
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
...
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405






406
407
408
409
410
411
412
413
414
...
434
435
436
437
438
439
440

441
442
443
444

445
446
447
448


449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
...
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518

519
520
521
522





523
524
525
526
527
528
529
...
533
534
535
536
537
538
539









540
541
542
543
544
545



546

547
548
549
550
551
552
553
...
620
621
622
623
624
625
626













































627
628
629
630
631
632
633
 *
 * Copyright (c) 1991-1994 The Regents of the University of California.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclEnv.c,v 1.1.2.6 1999/04/06 19:06:53 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

TCL_DECLARE_MUTEX(envMutex)	/* To serialize access to environ */

................................................................................
/*
 * Declarations for local procedures defined in this file:
 */

static char *		EnvTraceProc _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, char *name1, char *name2,
			    int flags));


static void		ReplaceString _ANSI_ARGS_((CONST char *oldStr,
			    char *newStr));
void			TclSetEnv _ANSI_ARGS_((CONST char *name,
			    CONST char *value));
void			TclUnsetEnv _ANSI_ARGS_((CONST char *name));

 
................................................................................
 */

void
TclSetupEnv(interp)
    Tcl_Interp *interp;		/* Interpreter whose "env" array is to be
				 * managed. */
{
    Tcl_DString envString;
    char *p1, *p2;

    int i;

    /*
     * Synchronize the values in the environ array with the contents
     * of the Tcl "env" variable.  To do this:
     *    1) Remove the trace that fires when the "env" var is unset.
     *    2) Unset the "env" variable.
     *    3) If there are no environ variables, create an empty "env"
     *       array.  Otherwise populate the array with current values.
     *    4) Add a trace that synchronizes the "env" array.
     */
    
    Tcl_UntraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
    
    Tcl_UnsetVar2(interp, "env", (char *) NULL, TCL_GLOBAL_ONLY); 
    



    if (environ[0] == NULL) {

	Tcl_Obj *varNamePtr;
	
	varNamePtr = Tcl_NewStringObj("env", -1);
	Tcl_IncrRefCount(varNamePtr);
	TclArraySet(interp, varNamePtr, NULL);	
	Tcl_DecrRefCount(varNamePtr);
    } else {
	Tcl_MutexLock(&envMutex);
	for (i = 0; environ[i] != NULL; i++) {
	    p1 = Tcl_ExternalToUtfDString(NULL, environ[i], -1, &envString);
	    p2 = strchr(p1, '=');
	    if (p2 == NULL) {
		/*

		 * This condition seem to happen occasionally under some
		 * versions of Solaris; ignore the entry.
		 */
		
		continue;
	    }


	    p2++;
	    p2[-1] = '\0';
	    Tcl_SetVar2(interp, "env", p1, p2, TCL_GLOBAL_ONLY);	

	    Tcl_DStringFree(&envString);

	}
	Tcl_MutexUnlock(&envMutex);
    }

    Tcl_TraceVar2(interp, "env", (char *) NULL,
	    TCL_GLOBAL_ONLY | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
	    TCL_TRACE_READS | TCL_TRACE_ARRAY,  EnvTraceProc,
	    (ClientData) NULL);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclSetEnv --
 *
................................................................................
 *	The environ array gets updated.
 *
 *----------------------------------------------------------------------
 */

void
TclSetEnv(name, value)
    CONST char *name;		/* Name of variable whose value is to be
				 * set (UTF-8). */
    CONST char *value;		/* New value for variable (UTF-8). */
{
    Tcl_DString envString;
    int index, length, nameLength;
    char *p, *p2, *oldValue;

    /*
     * Figure out where the entry is going to go.  If the name doesn't
     * already exist, enlarge the array if necessary to make room.  If the
     * name exists, free its old entry.
     */

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    if (index == -1) {
#ifndef USE_PUTENV
	if ((length + 2) > environSize) {
	    char **newEnviron;

	    newEnviron = (char **) ckalloc((unsigned)
		    ((length + 5) * sizeof(char *)));
................................................................................
	}
	index = length;
	environ[index + 1] = NULL;
#endif
	oldValue = NULL;
	nameLength = strlen(name);
    } else {
	char *env;

	/*
	 * Compare the new value to the existing value.  If they're
	 * the same then quit immediately (e.g. don't rewrite the
	 * value or propagate it to other interpreters).  Otherwise,
	 * when there are N interpreters there will be N! propagations
	 * of the same value among the interpreters.
	 */

	env = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envString);
	if (strcmp(value, (env + length + 1)) == 0) {
	    Tcl_DStringFree(&envString);
	    Tcl_MutexUnlock(&envMutex);
	    return;
	}
	Tcl_DStringFree(&envString);

	oldValue = environ[index];
	nameLength = length;
    }
	

    /*
     * Create a new entry.  Build a complete UTF string that contains
     * a "name=value" pattern.  Then convert the string to the native
     * encoding, and set the environ array value.
     */

    p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
    strcpy(p, name);
    p[nameLength] = '=';
    strcpy(p+nameLength+1, value);
    p2 = Tcl_UtfToExternalDString(NULL, p, -1, &envString);
    ckfree(p);
    

#ifdef USE_PUTENV
    /*
     * Update the system environment.
     */


    putenv(p2);
    index = TclpFindVariable(name, &length);
#else
    /*
     * Copy the native string to heap memory.
     */
    
    p = (char *) ckalloc((unsigned) (strlen(p2) + 1));
    strcpy(p, p2);
    environ[index] = p;
#endif

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] != p) {
	Tcl_DStringFree(&envString);
    } else {
	ReplaceString(oldValue, p);
    }

    Tcl_MutexUnlock(&envMutex);
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_PutEnv --
................................................................................
 */

int
Tcl_PutEnv(string)
    CONST char *string;		/* Info about environment variable in the
				 * form NAME=value. (native) */
{
    Tcl_DString nameString;   
    int nameLength;
    char *name, *value;

    if (string == NULL) {
	return 0;
    }

    /*
     * First convert the native string to UTF.  Then separate the
     * string into name and value parts, and call TclSetEnv to do
     * all of the real work.
     */

    name = Tcl_ExternalToUtfDString(NULL, string, -1, &nameString);
    value = strchr(name, '=');
    if (value == NULL) {
	return 0;
    }
    nameLength = value - name;
    if (nameLength == 0) {
	return 0;
    }

    value[0] = '\0';
    TclSetEnv(name, value+1);
    Tcl_DStringFree(&nameString);

    return 0;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclUnsetEnv --
................................................................................
 *	Interpreters are updated, as is environ.
 *
 *----------------------------------------------------------------------
 */

void
TclUnsetEnv(name)
    CONST char *name;		/* Name of variable to remove (UTF-8). */
{
    char *oldValue;
    int length, index;
#ifdef USE_PUTENV
    Tcl_DString envString;
    char *string;
#else
    char **envPtr;
#endif

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    /*
     * First make sure that the environment variable exists to avoid
     * doing needless work and to avoid recursion on the unset.
     */
    
    if (index == -1) {
................................................................................
     */

#ifdef USE_PUTENV
    string = ckalloc(length+2);
    memcpy((VOID *) string, (VOID *) name, (size_t) length);
    string[length] = '=';
    string[length+1] = '\0';
    
    Tcl_UtfToExternalDString(NULL, string, -1, &envString);
    ckfree(string);
    string = Tcl_DStringValue(&envString);
    putenv(string);

    /*
     * Watch out for versions of putenv that copy the string (e.g. VC++).
     * In this case we need to free the string immediately.  Otherwise
     * update the string in the cache.
     */

    if (environ[index] != string) {
	Tcl_DStringFree(&envString);
    } else {
	ReplaceString(oldValue, string);
    }
#else
    for (envPtr = environ+index+1; ; envPtr++) {
	envPtr[-1] = *envPtr;
	if (*envPtr == NULL) {
	    break;
	}
    }






    ReplaceString(oldValue, NULL);
#endif

    Tcl_MutexUnlock(&envMutex);
}
 
/*
 *---------------------------------------------------------------------------
 *
................................................................................
    CONST char *name;		/* Name of environment variable to find
				 * (UTF-8). */
    Tcl_DString *valuePtr;	/* Uninitialized or free DString in which
				 * the value of the environment variable is
				 * stored. */
{
    int length, index;

    char *result;

    Tcl_MutexLock(&envMutex);
    index = TclpFindVariable(name, &length);

    result = NULL;
    if (index != -1) {
	Tcl_DString envStr;
	


	result = Tcl_ExternalToUtfDString(NULL, environ[index], -1, &envStr);
	result += length;
	if (*result == '=') {
	    result++;
	    Tcl_DStringInit(valuePtr);
	    Tcl_DStringAppend(valuePtr, result, -1);
	    result = Tcl_DStringValue(valuePtr);
	} else {
	    result = NULL;
	}
	Tcl_DStringFree(&envStr);
    }
    Tcl_MutexUnlock(&envMutex);
    return result;
}
 
/*
 *----------------------------------------------------------------------
................................................................................
    Tcl_Interp *interp;		/* Interpreter whose "env" variable is
				 * being modified. */
    char *name1;		/* Better be "env". */
    char *name2;		/* Name of variable being modified, or NULL
				 * if whole array is being deleted (UTF-8). */
    int flags;			/* Indicates what's happening. */
{
    /*
     * For array traces, let TclSetupEnv do all the work.
     */

    if (flags & TCL_TRACE_ARRAY) {
	TclSetupEnv(interp);
	return NULL;
    }

    /*
     * If name2 is NULL, then return and do nothing.
     */
     
    if (name2 == NULL) {
	return NULL;
    }

    /*
     * If a value is being set, call TclSetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_WRITES) {

	char *value;
	
	value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY);
	TclSetEnv(name2, value);





    }

    /*
     * If a value is being read, call TclGetEnv to do all of the work.
     */

    if (flags & TCL_TRACE_READS) {
................................................................................
	value = TclGetEnv(name2, &valueString);
	if (value == NULL) {
	    return "no such variable";
	}
	Tcl_SetVar2(interp, name1, name2, value, 0);
	Tcl_DStringFree(&valueString);
    }










    /*
     * For unset traces, let TclUnsetEnv do all the work.
     */

    if (flags & TCL_TRACE_UNSETS) {



	TclUnsetEnv(name2);

    }
    return NULL;
}
 
/*
 *----------------------------------------------------------------------
 *
................................................................................
	}
	environCache = newCache;
	environCache[cacheSize] = (char *) newStr;
	environCache[cacheSize+1] = NULL;
	cacheSize += 5;
    }
}













































 
/*
 *----------------------------------------------------------------------
 *
 * TclFinalizeEnvironment --
 *
 *	This function releases any storage allocated by this module

Changes to generic/tclInt.h.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
....
1552
1553
1554
1555
1556
1557
1558


1559
1560
1561
1562
1563
1564
1565
....
1721
1722
1723
1724
1725
1726
1727


1728
1729
1730
1731
1732
1733
1734
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.1.2.19 1999/04/06 03:13:16 redman Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are
................................................................................
 */

EXTERN int		TclAccess _ANSI_ARGS_((CONST char *path,
			    int mode));
EXTERN int		TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));


EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
			    int numPids, Tcl_Pid *pidPtr,
			    Tcl_Channel errorChan));
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Channel inChan, Tcl_Channel outChan,
			    int toRead, Tcl_Obj *cmdPtr));
................................................................................
EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN char *		TclpFindExecutable _ANSI_ARGS_((
			    CONST char *argv0));


EXTERN void		TclpFree _ANSI_ARGS_((char *ptr));
EXTERN unsigned long	TclpGetClicks _ANSI_ARGS_((void));
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN unsigned long	TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void		TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int		TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char *name,






|







 







>
>







 







>
>







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
....
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
....
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
 * Copyright (c) 1993-1997 Lucent Technologies.
 * Copyright (c) 1994-1998 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclInt.h,v 1.1.2.20 1999/04/06 19:06:53 surles Exp $
 */

#ifndef _TCLINT
#define _TCLINT

/*
 * Common include files needed by most of the Tcl source files are
................................................................................
 */

EXTERN int		TclAccess _ANSI_ARGS_((CONST char *path,
			    int mode));
EXTERN int		TclAccessDeleteProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN int		TclAccessInsertProc _ANSI_ARGS_((TclAccessProc_ *proc));
EXTERN void		TclAllocateFreeObjects _ANSI_ARGS_((void));
EXTERN int		TclArraySet _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj));
EXTERN int		TclCleanupChildren _ANSI_ARGS_((Tcl_Interp *interp,
			    int numPids, Tcl_Pid *pidPtr,
			    Tcl_Channel errorChan));
EXTERN void		TclCleanupCommand _ANSI_ARGS_((Command *cmdPtr));
EXTERN int		TclCopyChannel _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Channel inChan, Tcl_Channel outChan,
			    int toRead, Tcl_Obj *cmdPtr));
................................................................................
EXTERN void		TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void		TclpFinalizeThreadData _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN void		TclpFinalizeThreadDataKey _ANSI_ARGS_((
			    Tcl_ThreadDataKey *keyPtr));
EXTERN char *		TclpFindExecutable _ANSI_ARGS_((
			    CONST char *argv0));
EXTERN int		TclpFindVariable _ANSI_ARGS_((CONST char *name,
			    int *lengthPtr));
EXTERN void		TclpFree _ANSI_ARGS_((char *ptr));
EXTERN unsigned long	TclpGetClicks _ANSI_ARGS_((void));
EXTERN Tcl_Channel	TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN unsigned long	TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void		TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int		TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char *		TclpGetUserHome _ANSI_ARGS_((CONST char *name,

Changes to generic/tclVar.c.

10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
....
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
....
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
....
3227
3228
3229
3230
3231
3232
3233
































































































3234
3235
3236
3237
3238
3239
3240
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.1.2.4 1999/02/10 23:31:20 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a
................................................................................
     * below.
     */

    enum {ARRAY_ANYMORE, ARRAY_DONESEARCH,  ARRAY_EXISTS, ARRAY_GET,
	  ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
	  ARRAY_STARTSEARCH}; 
    static char *arrayOptions[] = {"anymore", "donesearch", "exists",
				   "get", "names", "nextelement", "set", "size", "startsearch", 
				   (char *) NULL};

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
    int notArray;
    char *varName, *msg;
................................................................................
		}
	    }
	    Tcl_SetStringObj(resultPtr,
	            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
	    break;
	}
        case ARRAY_SET: {
	    Tcl_Obj **elemPtrs;
	    int listLen, i, result;
	    
	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
		return TCL_ERROR;
	    }
	    result = Tcl_ListObjGetElements(interp, objv[3], &listLen, 
                    &elemPtrs);
	    if (result != TCL_OK) {
	        return result;
	    }
	    if (listLen & 1) {
	        Tcl_ResetResult(interp);
		Tcl_AppendToObj(Tcl_GetObjResult(interp),
                        "list must have an even number of elements", -1);
		return TCL_ERROR;
	    }
	    if (listLen > 0) {
		for (i = 0;  i < listLen;  i += 2) {
		    if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i],
			    elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
			result = TCL_ERROR;
			break;
		    }
		}
		return result;
	    }

	    /*
	     * The list is empty make sure we have an array, or create
	     * one if necessary.
	     */
	    
	    if (varPtr != NULL) {
		if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
		    /*
		     * Already an array, done.
		     */
		    
		    return TCL_OK;
                }
		if (TclIsVarArrayElement(varPtr) ||
			!TclIsVarUndefined(varPtr)) {
		    /*
		     * Either an array element, or a scalar: lose!
		     */
		    
		    VarErrMsg(interp, varName, (char *)NULL, "array set",
                            needArray);
		    return TCL_ERROR;
                }
	    } else {
		/*
		 * Create variable for new array.
		 */
		
		varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
			/*createPart1*/ 1, /*createPart2*/ 0,
			&arrayPtr);
	    }
	    TclSetVarArray(varPtr);
	    TclClearVarUndefined(varPtr);
	    varPtr->value.tablePtr =
		(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
	    return TCL_OK;
	}
        case ARRAY_SIZE: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    int size;

	    if (objc != 3) {
................................................................................
    return TCL_OK;

    error:
    Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
	    (char *) NULL);
    return TCL_ERROR;
}
































































































 
/*
 *----------------------------------------------------------------------
 *
 * MakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"






|







 







|
|







 







<
<
<




<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
....
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
....
3097
3098
3099
3100
3101
3102
3103



3104
3105
3106
3107













3108














































3109
3110
3111
3112
3113
3114
3115
....
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.1.2.5 1999/04/06 19:06:54 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a
................................................................................
     * below.
     */

    enum {ARRAY_ANYMORE, ARRAY_DONESEARCH,  ARRAY_EXISTS, ARRAY_GET,
	  ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
	  ARRAY_STARTSEARCH}; 
    static char *arrayOptions[] = {"anymore", "donesearch", "exists",
				   "get", "names", "nextelement", "set",
				   "size", "startsearch", (char *) NULL};

    Interp *iPtr = (Interp *) interp;
    Var *varPtr, *arrayPtr;
    Tcl_HashEntry *hPtr;
    Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
    int notArray;
    char *varName, *msg;
................................................................................
		}
	    }
	    Tcl_SetStringObj(resultPtr,
	            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
	    break;
	}
        case ARRAY_SET: {



	    if (objc != 4) {
	        Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
		return TCL_ERROR;
	    }













	    return(TclArraySet(interp, objv[2], objv[3]));














































	}
        case ARRAY_SIZE: {
	    Tcl_HashSearch search;
	    Var *varPtr2;
	    int size;

	    if (objc != 3) {
................................................................................
    return TCL_OK;

    error:
    Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
	    (char *) NULL);
    return TCL_ERROR;
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclArraySet --
 *
 *	Set the elements of an array.  If there are no elements to
 *	set, create an empty array.  This routine is used by the
 *	Tcl_ArrayObjCmd and by the TclSetupEnv routine.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	A variable will be created if one does not already exist.
 *
 *----------------------------------------------------------------------
 */

int
TclArraySet(interp, arrayNameObj, arrayElemObj)
    Tcl_Interp *interp;		/* Current interpreter. */
    Tcl_Obj *arrayNameObj;	/* The array name. */
    Tcl_Obj *arrayElemObj;	/* The array elements list.  If this is
				 * NULL, create an empty array. */
{
    Var *varPtr, *arrayPtr;
    Tcl_Obj **elemPtrs;
    int result, elemLen, i;
    char *varName;
    
    varName = TclGetString(arrayNameObj);
    varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
            /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);

    if (arrayElemObj != NULL) {
	result = Tcl_ListObjGetElements(interp, arrayElemObj,
		&elemLen, &elemPtrs);
	if (result != TCL_OK) {
	    return result;
	}
	if (elemLen & 1) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendToObj(Tcl_GetObjResult(interp),
		    "list must have an even number of elements", -1);
	    return TCL_ERROR;
	}
	if (elemLen > 0) {
	    for (i = 0;  i < elemLen;  i += 2) {
		if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],
			elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
		    result = TCL_ERROR;
		    break;
		}
	    }
	    return result;
	}
    }
    
    /*
     * The list is empty make sure we have an array, or create
     * one if necessary.
     */
    
    if (varPtr != NULL) {
	if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
	    /*
	     * Already an array, done.
	     */
	    
	    return TCL_OK;
	}
	if (TclIsVarArrayElement(varPtr) ||
		!TclIsVarUndefined(varPtr)) {
	    /*
	     * Either an array element, or a scalar: lose!
	     */
	    
	    VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
	    return TCL_ERROR;
	}
    } else {
	/*
	 * Create variable for new array.
	 */
	
	varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0,
	        /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
    }
    TclSetVarArray(varPtr);
    TclClearVarUndefined(varPtr);
    varPtr->value.tablePtr =
	(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
    return TCL_OK;
}
 
/*
 *----------------------------------------------------------------------
 *
 * MakeUpvar --
 *
 *	This procedure does all of the work of the "global" and "upvar"

Changes to tests/env.test.

7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
166
167
168
169
170
171
172






























































173
174
175
176
177
178
179
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.1.2.6 1999/03/24 02:49:04 hershey Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed
................................................................................
test env-4.5 {unsetting international environment variables} {execCommandExists} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]
    unset env(\ub6)
    set result
} "\ub6=\ua7"































































# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
...
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: env.test,v 1.1.2.7 1999/04/06 19:06:56 surles Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

#
# These tests will run on any platform (and indeed crashed
................................................................................
test env-4.5 {unsetting international environment variables} {execCommandExists} {
    set env(\ub6) \ua7
    unset env(\ua7)
    set result [getenv]
    unset env(\ub6)
    set result
} "\ub6=\ua7"

test env-5.0 {corner cases - set a value, it should exist} {} {
    set temp [lindex [array names env] end]
    set x env($temp)
    set env($temp) a
    set result [set env($temp)]
    set env($temp) $x
    set result
} {a}
test env-5.1 {corner cases - remove one elem at a time} {} {
    # When no environment variables exist, the env var will
    # contain no entries.  The "array names" call synchs up
    # the C-level environ array with the Tcl level env array.
    # Make sure an empty Tcl array is created.

    set x [array get env]
    foreach e [array names env] {
	unset env($e)
    }
    set result [catch {array names env}]
    array set env $x
    set result
} {0}
test env-5.2 {corner cases - unset the env array} {} {
    # Unsetting a variable in an interp detaches the C-level
    # traces from the Tcl "env" variable.

    interp create i 
    i eval { unset env }
    i eval { set env(THIS_SHOULDNT_EXIST) a}
    set result [info exist env(THIS_SHOULDNT_EXIST)]
    interp delete i
    set result
} {0}
test env-5.3 {corner cases - unset the env in master should unset child} {} {
    # Variables deleted in a master interp should be deleted in
    # child interp too.

    interp create i 
    i eval { set env(THIS_SHOULD_EXIST) a}
    set result [set env(THIS_SHOULD_EXIST)]
    unset env(THIS_SHOULD_EXIST)
    lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}]
    interp delete i
    set result
} {a 1}
test env-5.4 {corner cases - unset the env array} {} {
    # The info exist command should be in synch with the env array.

    interp create i 
    i eval { set env(THIS_SHOULD_EXIST) a}
    set     result [info exists env(THIS_SHOULD_EXIST)]
    lappend result [set env(THIS_SHOULD_EXIST)]
    lappend result [info exists env(THIS_SHOULD_EXIST)]
    interp delete i
    set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {winOnly} {
    set env() a
    catch {set env()}
} {1}


# Restore the environment variables at the end of the test.

foreach name [array names env] {
    unset env($name)
}
foreach name [array names env2] {

Changes to unix/tclUnixInit.c.

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
481
482
483
484
485
486
487


























































488
489
490
491
492
493
494
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.12 1999/03/30 23:56:19 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
#if defined(__FreeBSD__)
#   include <floatingpoint.h>
................................................................................
	    user = "";
	}
    }
    Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&ds);

}


























































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
...
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
 *	Contains the Unix-specific interpreter initialization functions.
 *
 * Copyright (c) 1995-1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclUnixInit.c,v 1.1.2.13 1999/04/06 19:06:56 surles Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
#if defined(__FreeBSD__)
#   include <floatingpoint.h>
................................................................................
	    user = "";
	}
    }
    Tcl_SetVar2(interp, "tcl_platform", "user", user, TCL_GLOBAL_ONLY);
    Tcl_DStringFree(&ds);

}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this 
 *	routine is case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpFindVariable(name, lengthPtr)
    CONST char *name;		/* Name of desired environment variable
				 * (native). */
    int *lengthPtr;		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i, result = -1;
    register CONST char *env, *p1, *p2;
    Tcl_DString envString;

    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p2 = name;

	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = p2 - name;
	    result = i;
	    goto done;
	}
	
	Tcl_DStringFree(&envString);
    }
    
    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures

Changes to win/makefile.vc.

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: makefile.vc,v 1.1.2.23 1999/04/02 23:48:33 redman Exp $

# Does not depend on the presence of any environment variables in
# order to compile tcl; all needed information is derived from 
# location of the compiler directories.

#
# Project directories
................................................................................
#	-DTCL_COMPILE_DEBUG	Enables byte compilation logging.
#	-DTCL_COMPILE_STATS	Enables byte compilation statistics gathering.
#	-DUSE_TCLALLOC=0	Disables the Tcl memory allocator in favor
#				of the native malloc implementation.  This is
#				needed when using Purify.
#
#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
#DEBUGDEFINES = -DUSE_TCLALLOC=0

######################################################################
# Do not modify below this line
######################################################################

NAMEPREFIX = tcl
STUBPREFIX = $(NAMEPREFIX)stub






|







 







|







2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# 
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: makefile.vc,v 1.1.2.24 1999/04/06 19:06:57 surles Exp $

# Does not depend on the presence of any environment variables in
# order to compile tcl; all needed information is derived from 
# location of the compiler directories.

#
# Project directories
................................................................................
#	-DTCL_COMPILE_DEBUG	Enables byte compilation logging.
#	-DTCL_COMPILE_STATS	Enables byte compilation statistics gathering.
#	-DUSE_TCLALLOC=0	Disables the Tcl memory allocator in favor
#				of the native malloc implementation.  This is
#				needed when using Purify.
#
#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
DEBUGDEFINES = -DUSE_TCLALLOC=0

######################################################################
# Do not modify below this line
######################################################################

NAMEPREFIX = tcl
STUBPREFIX = $(NAMEPREFIX)stub

Changes to win/tclWinInit.c.

5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
570
571
572
573
574
575
576




















































































577
578
579
580
581
582
583
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.8 1999/03/12 23:29:22 surles Exp $
 */

#include "tclWinInt.h"
#include <winreg.h>
#include <winnt.h>
#include <winbase.h>

................................................................................
	Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
		TCL_GLOBAL_ONLY);
    } else {
	Tcl_SetVar2(interp, "tcl_platform", "user", "", TCL_GLOBAL_ONLY);
    }
    Tcl_DStringFree(&ds);
}




















































































 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
...
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
 *
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclWinInit.c,v 1.1.2.9 1999/04/06 19:06:57 surles Exp $
 */

#include "tclWinInt.h"
#include <winreg.h>
#include <winnt.h>
#include <winbase.h>

................................................................................
	Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
		TCL_GLOBAL_ONLY);
    } else {
	Tcl_SetVar2(interp, "tcl_platform", "user", "", TCL_GLOBAL_ONLY);
    }
    Tcl_DStringFree(&ds);
}
 
/*
 *----------------------------------------------------------------------
 *
 * TclpFindVariable --
 *
 *	Locate the entry in environ for a given name.  On Unix this 
 *	routine is case sensetive, on Windows this matches mioxed case.
 *
 * Results:
 *	The return value is the index in environ of an entry with the
 *	name "name", or -1 if there is no such entry.   The integer at
 *	*lengthPtr is filled in with the length of name (if a matching
 *	entry is found) or the length of the environ array (if no matching
 *	entry is found).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclpFindVariable(name, lengthPtr)
    CONST char *name;		/* Name of desired environment variable
				 * (UTF-8). */
    int *lengthPtr;		/* Used to return length of name (for
				 * successful searches) or number of non-NULL
				 * entries in environ (for unsuccessful
				 * searches). */
{
    int i, length, result = -1;
    register CONST char *env, *p1, *p2;
    char *envUpper, *nameUpper;
    Tcl_DString envString;

    /*
     * Convert the name to all upper case for the case insensitive
     * comparison.
     */

    length = strlen(name);
    nameUpper = (char *) ckalloc((unsigned) length+1);
    memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
    Tcl_UtfToUpper(nameUpper);
    
    Tcl_DStringInit(&envString);
    for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
	/*
	 * Chop the env string off after the equal sign, then Convert
	 * the name to all upper case, so we do not have to convert
	 * all the characters after the equal sign.
	 */
	
	envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
	p1 = strchr(envUpper, '=');
	if (p1 == NULL) {
	    continue;
	}
	length = p1 - envUpper;
	Tcl_DStringSetLength(&envString, length+1);
	Tcl_UtfToUpper(envUpper);

	p1 = envUpper;
	p2 = nameUpper;
	for (; *p2 == *p1; p1++, p2++) {
	    /* NULL loop body. */
	}
	if ((*p1 == '=') && (*p2 == '\0')) {
	    *lengthPtr = length;
	    result = i;
	    goto done;
	}
	
	Tcl_DStringFree(&envString);
    }
    
    *lengthPtr = i;

    done:
    Tcl_DStringFree(&envString);
    ckfree(nameUpper);
    return result;
}
 
/*
 *----------------------------------------------------------------------
 *
 * Tcl_Init --
 *
 *	This procedure is typically invoked by Tcl_AppInit procedures