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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 67 - (hide annotations) (download)
Mon Oct 31 00:57:34 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 154239 byte(s)
Header and footer cleanup.
1 dashley 64 /* $Header$ */
2 dashley 25 /*
3     * tclVar.c --
4     *
5     * This file contains routines that implement Tcl variables
6     * (both scalars and arrays).
7     *
8     * The implementation of arrays is modelled after an initial
9     * implementation by Mark Diekhans and Karl Lehenbauer.
10     *
11     * Copyright (c) 1987-1994 The Regents of the University of California.
12     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
13     * Copyright (c) 1998-1999 by Scriptics Corporation.
14     *
15     * See the file "license.terms" for information on usage and redistribution
16     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
17     *
18     * RCS: @(#) $Id: tclvar.c,v 1.1.1.1 2001/06/13 04:48:07 dtashley Exp $
19     */
20    
21     #include "tclInt.h"
22     #include "tclPort.h"
23    
24     /*
25     * The strings below are used to indicate what went wrong when a
26     * variable access is denied.
27     */
28    
29     static char *noSuchVar = "no such variable";
30     static char *isArray = "variable is array";
31     static char *needArray = "variable isn't array";
32     static char *noSuchElement = "no such element in array";
33     static char *danglingElement = "upvar refers to element in deleted array";
34     static char *danglingVar = "upvar refers to variable in deleted namespace";
35     static char *badNamespace = "parent namespace doesn't exist";
36     static char *missingName = "missing variable name";
37     static char *isArrayElement = "name refers to an element in an array";
38    
39     /*
40     * Forward references to procedures defined later in this file:
41     */
42    
43     static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
44     Var *varPtr, char *part1, char *part2,
45     int flags));
46     static void CleanupVar _ANSI_ARGS_((Var *varPtr,
47     Var *arrayPtr));
48     static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
49     static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
50     char *arrayName, Var *varPtr, int flags));
51     static int MakeUpvar _ANSI_ARGS_((
52     Interp *iPtr, CallFrame *framePtr,
53     char *otherP1, char *otherP2, int otherFlags,
54     char *myName, int myFlags));
55     static Var * NewVar _ANSI_ARGS_((void));
56     static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
57     Var *varPtr, char *varName, char *string));
58     static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
59     char *part1, char *part2, char *operation,
60     char *reason));
61    
62     /*
63     *----------------------------------------------------------------------
64     *
65     * TclLookupVar --
66     *
67     * This procedure is used by virtually all of the variable code to
68     * locate a variable given its name(s).
69     *
70     * Results:
71     * The return value is a pointer to the variable structure indicated by
72     * part1 and part2, or NULL if the variable couldn't be found. If the
73     * variable is found, *arrayPtrPtr is filled in with the address of the
74     * variable structure for the array that contains the variable (or NULL
75     * if the variable is a scalar). If the variable can't be found and
76     * either createPart1 or createPart2 are 1, a new as-yet-undefined
77     * (VAR_UNDEFINED) variable structure is created, entered into a hash
78     * table, and returned.
79     *
80     * If the variable isn't found and creation wasn't specified, or some
81     * other error occurs, NULL is returned and an error message is left in
82     * the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
83     *
84     * Note: it's possible for the variable returned to be VAR_UNDEFINED
85     * even if createPart1 or createPart2 are 1 (these only cause the hash
86     * table entry or array to be created). For example, the variable might
87     * be a global that has been unset but is still referenced by a
88     * procedure, or a variable that has been unset but it only being kept
89     * in existence (if VAR_UNDEFINED) by a trace.
90     *
91     * Side effects:
92     * New hashtable entries may be created if createPart1 or createPart2
93     * are 1.
94     *
95     *----------------------------------------------------------------------
96     */
97    
98     Var *
99     TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
100     arrayPtrPtr)
101     Tcl_Interp *interp; /* Interpreter to use for lookup. */
102     register char *part1; /* If part2 isn't NULL, this is the name of
103     * an array. Otherwise, this
104     * is a full variable name that could
105     * include a parenthesized array element. */
106     char *part2; /* Name of element within array, or NULL. */
107     int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
108     * and TCL_LEAVE_ERR_MSG bits matter. */
109     char *msg; /* Verb to use in error messages, e.g.
110     * "read" or "set". Only needed if
111     * TCL_LEAVE_ERR_MSG is set in flags. */
112     int createPart1; /* If 1, create hash table entry for part 1
113     * of name, if it doesn't already exist. If
114     * 0, return error if it doesn't exist. */
115     int createPart2; /* If 1, create hash table entry for part 2
116     * of name, if it doesn't already exist. If
117     * 0, return error if it doesn't exist. */
118     Var **arrayPtrPtr; /* If the name refers to an element of an
119     * array, *arrayPtrPtr gets filled in with
120     * address of array variable. Otherwise
121     * this is set to NULL. */
122     {
123     Interp *iPtr = (Interp *) interp;
124     CallFrame *varFramePtr = iPtr->varFramePtr;
125     /* Points to the procedure call frame whose
126     * variables are currently in use. Same as
127     * the current procedure's frame, if any,
128     * unless an "uplevel" is executing. */
129     Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
130     * to look up the variable. */
131     Tcl_Var var; /* Used to search for global names. */
132     Var *varPtr; /* Points to the Var structure returned for
133     * the variable. */
134     char *elName; /* Name of array element or NULL; may be
135     * same as part2, or may be openParen+1. */
136     char *openParen, *closeParen;
137     /* If this procedure parses a name into
138     * array and index, these point to the
139     * parens around the index. Otherwise they
140     * are NULL. These are needed to restore
141     * the parens after parsing the name. */
142     Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
143     ResolverScheme *resPtr;
144     Tcl_HashEntry *hPtr;
145     register char *p;
146     int new, i, result;
147    
148     varPtr = NULL;
149     *arrayPtrPtr = NULL;
150     openParen = closeParen = NULL;
151     varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
152    
153     /*
154     * Parse part1 into array name and index.
155     * Always check if part1 is an array element name and allow it only if
156     * part2 is not given.
157     * (if one does not care about creating array elements that can't be used
158     * from tcl, and prefer slightly better performance, one can put
159     * the following in an if (part2 == NULL) { ... } block and remove
160     * the part2's test and error reporting or move that code in array set)
161     */
162    
163     elName = part2;
164     for (p = part1; *p ; p++) {
165     if (*p == '(') {
166     openParen = p;
167     do {
168     p++;
169     } while (*p != '\0');
170     p--;
171     if (*p == ')') {
172     if (part2 != NULL) {
173     openParen = NULL;
174     if (flags & TCL_LEAVE_ERR_MSG) {
175     VarErrMsg(interp, part1, part2, msg, needArray);
176     }
177     goto done;
178     }
179     closeParen = p;
180     *openParen = 0;
181     elName = openParen+1;
182     } else {
183     openParen = NULL;
184     }
185     break;
186     }
187     }
188    
189     /*
190     * If this namespace has a variable resolver, then give it first
191     * crack at the variable resolution. It may return a Tcl_Var
192     * value, it may signal to continue onward, or it may signal
193     * an error.
194     */
195     if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) {
196     cxtNsPtr = iPtr->globalNsPtr;
197     } else {
198     cxtNsPtr = iPtr->varFramePtr->nsPtr;
199     }
200    
201     if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
202     resPtr = iPtr->resolverPtr;
203    
204     if (cxtNsPtr->varResProc) {
205     result = (*cxtNsPtr->varResProc)(interp, part1,
206     (Tcl_Namespace *) cxtNsPtr, flags, &var);
207     } else {
208     result = TCL_CONTINUE;
209     }
210    
211     while (result == TCL_CONTINUE && resPtr) {
212     if (resPtr->varResProc) {
213     result = (*resPtr->varResProc)(interp, part1,
214     (Tcl_Namespace *) cxtNsPtr, flags, &var);
215     }
216     resPtr = resPtr->nextPtr;
217     }
218    
219     if (result == TCL_OK) {
220     varPtr = (Var *) var;
221     goto lookupVarPart2;
222     } else if (result != TCL_CONTINUE) {
223     return (Var *) NULL;
224     }
225     }
226    
227     /*
228     * Look up part1. Look it up as either a namespace variable or as a
229     * local variable in a procedure call frame (varFramePtr).
230     * Interpret part1 as a namespace variable if:
231     * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
232     * 2) there is no active frame (we're at the global :: scope),
233     * 3) the active frame was pushed to define the namespace context
234     * for a "namespace eval" or "namespace inscope" command,
235     * 4) the name has namespace qualifiers ("::"s).
236     * Otherwise, if part1 is a local variable, search first in the
237     * frame's array of compiler-allocated local variables, then in its
238     * hashtable for runtime-created local variables.
239     *
240     * If createPart1 and the variable isn't found, create the variable and,
241     * if necessary, create varFramePtr's local var hashtable.
242     */
243    
244     if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
245     || (varFramePtr == NULL)
246     || !varFramePtr->isProcCallFrame
247     || (strstr(part1, "::") != NULL)) {
248     char *tail;
249    
250     /*
251     * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
252     * or otherwise generate our own error!
253     */
254     var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL,
255     flags & ~TCL_LEAVE_ERR_MSG);
256     if (var != (Tcl_Var) NULL) {
257     varPtr = (Var *) var;
258     }
259     if (varPtr == NULL) {
260     if (createPart1) { /* var wasn't found so create it */
261     TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL,
262     flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
263    
264     if (varNsPtr == NULL) {
265     if (flags & TCL_LEAVE_ERR_MSG) {
266     VarErrMsg(interp, part1, part2, msg, badNamespace);
267     }
268     goto done;
269     }
270     if (tail == NULL) {
271     if (flags & TCL_LEAVE_ERR_MSG) {
272     VarErrMsg(interp, part1, part2, msg, missingName);
273     }
274     goto done;
275     }
276     hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
277     varPtr = NewVar();
278     Tcl_SetHashValue(hPtr, varPtr);
279     varPtr->hPtr = hPtr;
280     varPtr->nsPtr = varNsPtr;
281     } else { /* var wasn't found and not to create it */
282     if (flags & TCL_LEAVE_ERR_MSG) {
283     VarErrMsg(interp, part1, part2, msg, noSuchVar);
284     }
285     goto done;
286     }
287     }
288     } else { /* local var: look in frame varFramePtr */
289     Proc *procPtr = varFramePtr->procPtr;
290     int localCt = procPtr->numCompiledLocals;
291     CompiledLocal *localPtr = procPtr->firstLocalPtr;
292     Var *localVarPtr = varFramePtr->compiledLocals;
293     int part1Len = strlen(part1);
294    
295     for (i = 0; i < localCt; i++) {
296     if (!TclIsVarTemporary(localPtr)) {
297     register char *localName = localVarPtr->name;
298     if ((part1[0] == localName[0])
299     && (part1Len == localPtr->nameLength)
300     && (strcmp(part1, localName) == 0)) {
301     varPtr = localVarPtr;
302     break;
303     }
304     }
305     localVarPtr++;
306     localPtr = localPtr->nextPtr;
307     }
308     if (varPtr == NULL) { /* look in the frame's var hash table */
309     tablePtr = varFramePtr->varTablePtr;
310     if (createPart1) {
311     if (tablePtr == NULL) {
312     tablePtr = (Tcl_HashTable *)
313     ckalloc(sizeof(Tcl_HashTable));
314     Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
315     varFramePtr->varTablePtr = tablePtr;
316     }
317     hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
318     if (new) {
319     varPtr = NewVar();
320     Tcl_SetHashValue(hPtr, varPtr);
321     varPtr->hPtr = hPtr;
322     varPtr->nsPtr = NULL; /* a local variable */
323     } else {
324     varPtr = (Var *) Tcl_GetHashValue(hPtr);
325     }
326     } else {
327     hPtr = NULL;
328     if (tablePtr != NULL) {
329     hPtr = Tcl_FindHashEntry(tablePtr, part1);
330     }
331     if (hPtr == NULL) {
332     if (flags & TCL_LEAVE_ERR_MSG) {
333     VarErrMsg(interp, part1, part2, msg, noSuchVar);
334     }
335     goto done;
336     }
337     varPtr = (Var *) Tcl_GetHashValue(hPtr);
338     }
339     }
340     }
341    
342     lookupVarPart2:
343     if (openParen != NULL) {
344     *openParen = '(';
345     openParen = NULL;
346     }
347    
348     /*
349     * If varPtr is a link variable, we have a reference to some variable
350     * that was created through an "upvar" or "global" command. Traverse
351     * through any links until we find the referenced variable.
352     */
353    
354     while (TclIsVarLink(varPtr)) {
355     varPtr = varPtr->value.linkPtr;
356     }
357    
358     /*
359     * If we're not dealing with an array element, return varPtr.
360     */
361    
362     if (elName == NULL) {
363     goto done;
364     }
365    
366     /*
367     * We're dealing with an array element. Make sure the variable is an
368     * array and look up the element (create the element if desired).
369     */
370    
371     if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) {
372     if (!createPart1) {
373     if (flags & TCL_LEAVE_ERR_MSG) {
374     VarErrMsg(interp, part1, part2, msg, noSuchVar);
375     }
376     varPtr = NULL;
377     goto done;
378     }
379    
380     /*
381     * Make sure we are not resurrecting a namespace variable from a
382     * deleted namespace!
383     */
384     if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
385     if (flags & TCL_LEAVE_ERR_MSG) {
386     VarErrMsg(interp, part1, part2, msg, danglingVar);
387     }
388     varPtr = NULL;
389     goto done;
390     }
391    
392     TclSetVarArray(varPtr);
393     TclClearVarUndefined(varPtr);
394     varPtr->value.tablePtr =
395     (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
396     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
397     } else if (!TclIsVarArray(varPtr)) {
398     if (flags & TCL_LEAVE_ERR_MSG) {
399     VarErrMsg(interp, part1, part2, msg, needArray);
400     }
401     varPtr = NULL;
402     goto done;
403     }
404     *arrayPtrPtr = varPtr;
405     if (closeParen != NULL) {
406     *closeParen = 0;
407     }
408     if (createPart2) {
409     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new);
410     if (closeParen != NULL) {
411     *closeParen = ')';
412     }
413     if (new) {
414     if (varPtr->searchPtr != NULL) {
415     DeleteSearches(varPtr);
416     }
417     varPtr = NewVar();
418     Tcl_SetHashValue(hPtr, varPtr);
419     varPtr->hPtr = hPtr;
420     varPtr->nsPtr = varNsPtr;
421     TclSetVarArrayElement(varPtr);
422     }
423     } else {
424     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName);
425     if (closeParen != NULL) {
426     *closeParen = ')';
427     }
428     if (hPtr == NULL) {
429     if (flags & TCL_LEAVE_ERR_MSG) {
430     VarErrMsg(interp, part1, part2, msg, noSuchElement);
431     }
432     varPtr = NULL;
433     goto done;
434     }
435     }
436     varPtr = (Var *) Tcl_GetHashValue(hPtr);
437    
438     done:
439     if (openParen != NULL) {
440     *openParen = '(';
441     }
442     return varPtr;
443     }
444    
445     /*
446     *----------------------------------------------------------------------
447     *
448     * Tcl_GetVar --
449     *
450     * Return the value of a Tcl variable as a string.
451     *
452     * Results:
453     * The return value points to the current value of varName as a string.
454     * If the variable is not defined or can't be read because of a clash
455     * in array usage then a NULL pointer is returned and an error message
456     * is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
457     * Note: the return value is only valid up until the next change to the
458     * variable; if you depend on the value lasting longer than that, then
459     * make yourself a private copy.
460     *
461     * Side effects:
462     * None.
463     *
464     *----------------------------------------------------------------------
465     */
466    
467     char *
468     Tcl_GetVar(interp, varName, flags)
469     Tcl_Interp *interp; /* Command interpreter in which varName is
470     * to be looked up. */
471     char *varName; /* Name of a variable in interp. */
472     int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
473     * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
474     * bits. */
475     {
476     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
477     }
478    
479     /*
480     *----------------------------------------------------------------------
481     *
482     * Tcl_GetVar2 --
483     *
484     * Return the value of a Tcl variable as a string, given a two-part
485     * name consisting of array name and element within array.
486     *
487     * Results:
488     * The return value points to the current value of the variable given
489     * by part1 and part2 as a string. If the specified variable doesn't
490     * exist, or if there is a clash in array usage, then NULL is returned
491     * and a message will be left in the interp's result if the
492     * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
493     * up until the next change to the variable; if you depend on the value
494     * lasting longer than that, then make yourself a private copy.
495     *
496     * Side effects:
497     * None.
498     *
499     *----------------------------------------------------------------------
500     */
501    
502     char *
503     Tcl_GetVar2(interp, part1, part2, flags)
504     Tcl_Interp *interp; /* Command interpreter in which variable is
505     * to be looked up. */
506     char *part1; /* Name of an array (if part2 is non-NULL)
507     * or the name of a variable. */
508     char *part2; /* If non-NULL, gives the name of an element
509     * in the array part1. */
510     int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
511     * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
512     * bits. */
513     {
514     Tcl_Obj *objPtr;
515    
516     objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
517     if (objPtr == NULL) {
518     return NULL;
519     }
520     return TclGetString(objPtr);
521     }
522     /*
523     *----------------------------------------------------------------------
524     *
525     * Tcl_ObjGetVar2 --
526     *
527     * Return the value of a Tcl variable as a Tcl object, given a
528     * two-part name consisting of array name and element within array.
529     *
530     * Results:
531     * The return value points to the current object value of the variable
532     * given by part1Ptr and part2Ptr. If the specified variable doesn't
533     * exist, or if there is a clash in array usage, then NULL is returned
534     * and a message will be left in the interpreter's result if the
535     * TCL_LEAVE_ERR_MSG flag is set.
536     *
537     * Side effects:
538     * The ref count for the returned object is _not_ incremented to
539     * reflect the returned reference; if you want to keep a reference to
540     * the object you must increment its ref count yourself.
541     *
542     *----------------------------------------------------------------------
543     */
544    
545     Tcl_Obj *
546     Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
547     Tcl_Interp *interp; /* Command interpreter in which variable is
548     * to be looked up. */
549     register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
550     * an array (if part2 is non-NULL) or the
551     * name of a variable. */
552     register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
553     * the name of an element in the array
554     * part1Ptr. */
555     int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
556     * TCL_LEAVE_ERR_MSG, and
557     * TCL_PARSE_PART1 bits. */
558     {
559     char *part1, *part2;
560    
561     part1 = Tcl_GetString(part1Ptr);
562     if (part2Ptr != NULL) {
563     part2 = Tcl_GetString(part2Ptr);
564     } else {
565     part2 = NULL;
566     }
567    
568     return Tcl_GetVar2Ex(interp, part1, part2, flags);
569     }
570    
571     /*
572     *----------------------------------------------------------------------
573     *
574     * Tcl_GetVar2Ex --
575     *
576     * Return the value of a Tcl variable as a Tcl object, given a
577     * two-part name consisting of array name and element within array.
578     *
579     * Results:
580     * The return value points to the current object value of the variable
581     * given by part1Ptr and part2Ptr. If the specified variable doesn't
582     * exist, or if there is a clash in array usage, then NULL is returned
583     * and a message will be left in the interpreter's result if the
584     * TCL_LEAVE_ERR_MSG flag is set.
585     *
586     * Side effects:
587     * The ref count for the returned object is _not_ incremented to
588     * reflect the returned reference; if you want to keep a reference to
589     * the object you must increment its ref count yourself.
590     *
591     *----------------------------------------------------------------------
592     */
593    
594     Tcl_Obj *
595     Tcl_GetVar2Ex(interp, part1, part2, flags)
596     Tcl_Interp *interp; /* Command interpreter in which variable is
597     * to be looked up. */
598     char *part1; /* Name of an array (if part2 is non-NULL)
599     * or the name of a variable. */
600     char *part2; /* If non-NULL, gives the name of an element
601     * in the array part1. */
602     int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
603     * and TCL_LEAVE_ERR_MSG bits. */
604     {
605     Interp *iPtr = (Interp *) interp;
606     register Var *varPtr;
607     Var *arrayPtr;
608     char *msg;
609    
610     varPtr = TclLookupVar(interp, part1, part2, flags, "read",
611     /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
612     if (varPtr == NULL) {
613     return NULL;
614     }
615    
616     /*
617     * Invoke any traces that have been set for the variable.
618     */
619    
620     if ((varPtr->tracePtr != NULL)
621     || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
622     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
623     (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS);
624     if (msg != NULL) {
625     if (flags & TCL_LEAVE_ERR_MSG) {
626     VarErrMsg(interp, part1, part2, "read", msg);
627     }
628     goto errorReturn;
629     }
630     }
631    
632     /*
633     * Return the element if it's an existing scalar variable.
634     */
635    
636     if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
637     return varPtr->value.objPtr;
638     }
639    
640     if (flags & TCL_LEAVE_ERR_MSG) {
641     if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL)
642     && !TclIsVarUndefined(arrayPtr)) {
643     msg = noSuchElement;
644     } else if (TclIsVarArray(varPtr)) {
645     msg = isArray;
646     } else {
647     msg = noSuchVar;
648     }
649     VarErrMsg(interp, part1, part2, "read", msg);
650     }
651    
652     /*
653     * An error. If the variable doesn't exist anymore and no-one's using
654     * it, then free up the relevant structures and hash table entries.
655     */
656    
657     errorReturn:
658     if (TclIsVarUndefined(varPtr)) {
659     CleanupVar(varPtr, arrayPtr);
660     }
661     return NULL;
662     }
663    
664     /*
665     *----------------------------------------------------------------------
666     *
667     * TclGetIndexedScalar --
668     *
669     * Return the Tcl object value of a local scalar variable in the active
670     * procedure, given its index in the procedure's array of compiler
671     * allocated local variables.
672     *
673     * Results:
674     * The return value points to the current object value of the variable
675     * given by localIndex. If the specified variable doesn't exist, or
676     * there is a clash in array usage, or an error occurs while executing
677     * variable traces, then NULL is returned and a message will be left in
678     * the interpreter's result if leaveErrorMsg is 1.
679     *
680     * Side effects:
681     * The ref count for the returned object is _not_ incremented to
682     * reflect the returned reference; if you want to keep a reference to
683     * the object you must increment its ref count yourself.
684     *
685     *----------------------------------------------------------------------
686     */
687    
688     Tcl_Obj *
689     TclGetIndexedScalar(interp, localIndex, leaveErrorMsg)
690     Tcl_Interp *interp; /* Command interpreter in which variable is
691     * to be looked up. */
692     register int localIndex; /* Index of variable in procedure's array
693     * of local variables. */
694     int leaveErrorMsg; /* 1 if to leave an error message in
695     * interpreter's result on an error.
696     * Otherwise no error message is left. */
697     {
698     Interp *iPtr = (Interp *) interp;
699     CallFrame *varFramePtr = iPtr->varFramePtr;
700     /* Points to the procedure call frame whose
701     * variables are currently in use. Same as
702     * the current procedure's frame, if any,
703     * unless an "uplevel" is executing. */
704     Var *compiledLocals = varFramePtr->compiledLocals;
705     register Var *varPtr; /* Points to the variable's in-frame Var
706     * structure. */
707     char *varName; /* Name of the local variable. */
708     char *msg;
709    
710     #ifdef TCL_COMPILE_DEBUG
711     int localCt = varFramePtr->procPtr->numCompiledLocals;
712    
713     if (compiledLocals == NULL) {
714     fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n",
715     localIndex, (unsigned int) varFramePtr);
716     panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
717     (unsigned int) varFramePtr);
718     }
719     if ((localIndex < 0) || (localIndex >= localCt)) {
720     fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n",
721     localIndex, (unsigned int) varFramePtr, localCt);
722     panic("TclGetIndexedScalar: bad local index %i in frame 0x%x",
723     localIndex, (unsigned int) varFramePtr);
724     }
725     #endif /* TCL_COMPILE_DEBUG */
726    
727     varPtr = &(compiledLocals[localIndex]);
728     varName = varPtr->name;
729    
730     /*
731     * If varPtr is a link variable, we have a reference to some variable
732     * that was created through an "upvar" or "global" command, or we have a
733     * reference to a variable in an enclosing namespace. Traverse through
734     * any links until we find the referenced variable.
735     */
736    
737     while (TclIsVarLink(varPtr)) {
738     varPtr = varPtr->value.linkPtr;
739     }
740    
741     /*
742     * Invoke any traces that have been set for the variable.
743     */
744    
745     if (varPtr->tracePtr != NULL) {
746     msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL,
747     TCL_TRACE_READS);
748     if (msg != NULL) {
749     if (leaveErrorMsg) {
750     VarErrMsg(interp, varName, NULL, "read", msg);
751     }
752     return NULL;
753     }
754     }
755    
756     /*
757     * Make sure we're dealing with a scalar variable and not an array, and
758     * that the variable exists (isn't undefined).
759     */
760    
761     if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) {
762     if (leaveErrorMsg) {
763     if (TclIsVarArray(varPtr)) {
764     msg = isArray;
765     } else {
766     msg = noSuchVar;
767     }
768     VarErrMsg(interp, varName, NULL, "read", msg);
769    
770     }
771     return NULL;
772     }
773     return varPtr->value.objPtr;
774     }
775    
776     /*
777     *----------------------------------------------------------------------
778     *
779     * TclGetElementOfIndexedArray --
780     *
781     * Return the Tcl object value for an element in a local array
782     * variable. The element is named by the object elemPtr while the
783     * array is specified by its index in the active procedure's array
784     * of compiler allocated local variables.
785     *
786     * Results:
787     * The return value points to the current object value of the
788     * element. If the specified array or element doesn't exist, or there
789     * is a clash in array usage, or an error occurs while executing
790     * variable traces, then NULL is returned and a message will be left in
791     * the interpreter's result if leaveErrorMsg is 1.
792     *
793     * Side effects:
794     * The ref count for the returned object is _not_ incremented to
795     * reflect the returned reference; if you want to keep a reference to
796     * the object you must increment its ref count yourself.
797     *
798     *----------------------------------------------------------------------
799     */
800    
801     Tcl_Obj *
802     TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
803     Tcl_Interp *interp; /* Command interpreter in which variable is
804     * to be looked up. */
805     int localIndex; /* Index of array variable in procedure's
806     * array of local variables. */
807     Tcl_Obj *elemPtr; /* Points to an object holding the name of
808     * an element to get in the array. */
809     int leaveErrorMsg; /* 1 if to leave an error message in
810     * the interpreter's result on an error.
811     * Otherwise no error message is left. */
812     {
813     Interp *iPtr = (Interp *) interp;
814     CallFrame *varFramePtr = iPtr->varFramePtr;
815     /* Points to the procedure call frame whose
816     * variables are currently in use. Same as
817     * the current procedure's frame, if any,
818     * unless an "uplevel" is executing. */
819     Var *compiledLocals = varFramePtr->compiledLocals;
820     Var *arrayPtr; /* Points to the array's in-frame Var
821     * structure. */
822     char *arrayName; /* Name of the local array. */
823     Tcl_HashEntry *hPtr;
824     Var *varPtr = NULL; /* Points to the element's Var structure
825     * that we return. Initialized to avoid
826     * compiler warning. */
827     char *elem, *msg;
828     int new;
829    
830     #ifdef TCL_COMPILE_DEBUG
831     Proc *procPtr = varFramePtr->procPtr;
832     int localCt = procPtr->numCompiledLocals;
833    
834     if (compiledLocals == NULL) {
835     fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n",
836     localIndex, (unsigned int) varFramePtr);
837     panic("TclGetIndexedScalar: no compiled locals in frame 0x%x",
838     (unsigned int) varFramePtr);
839     }
840     if ((localIndex < 0) || (localIndex >= localCt)) {
841     fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n",
842     localIndex, (unsigned int) varFramePtr, localCt);
843     panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x",
844     localIndex, (unsigned int) varFramePtr);
845     }
846     #endif /* TCL_COMPILE_DEBUG */
847    
848     elem = TclGetString(elemPtr);
849     arrayPtr = &(compiledLocals[localIndex]);
850     arrayName = arrayPtr->name;
851    
852     /*
853     * If arrayPtr is a link variable, we have a reference to some variable
854     * that was created through an "upvar" or "global" command, or we have a
855     * reference to a variable in an enclosing namespace. Traverse through
856     * any links until we find the referenced variable.
857     */
858    
859     while (TclIsVarLink(arrayPtr)) {
860     arrayPtr = arrayPtr->value.linkPtr;
861     }
862    
863     /*
864     * Make sure we're dealing with an array and that the array variable
865     * exists (isn't undefined).
866     */
867    
868     if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) {
869     if (leaveErrorMsg) {
870     VarErrMsg(interp, arrayName, elem, "read", noSuchVar);
871     }
872     goto errorReturn;
873     }
874    
875     /*
876     * Look up the element. Note that we must create the element (but leave
877     * it marked undefined) if it does not already exist. This allows a
878     * trace to create new array elements "on the fly" that did not exist
879     * before. A trace is always passed a variable for the array element. If
880     * the trace does not define the variable, it will be deleted below (at
881     * errorReturn) and an error returned.
882     */
883    
884     hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
885     if (new) {
886     if (arrayPtr->searchPtr != NULL) {
887     DeleteSearches(arrayPtr);
888     }
889     varPtr = NewVar();
890     Tcl_SetHashValue(hPtr, varPtr);
891     varPtr->hPtr = hPtr;
892     varPtr->nsPtr = varFramePtr->nsPtr;
893     TclSetVarArrayElement(varPtr);
894     } else {
895     varPtr = (Var *) Tcl_GetHashValue(hPtr);
896     }
897    
898     /*
899     * Invoke any traces that have been set for the element variable.
900     */
901    
902     if ((varPtr->tracePtr != NULL)
903     || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
904     msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
905     TCL_TRACE_READS);
906     if (msg != NULL) {
907     if (leaveErrorMsg) {
908     VarErrMsg(interp, arrayName, elem, "read", msg);
909     }
910     goto errorReturn;
911     }
912     }
913    
914     /*
915     * Return the element if it's an existing scalar variable.
916     */
917    
918     if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
919     return varPtr->value.objPtr;
920     }
921    
922     if (leaveErrorMsg) {
923     if (TclIsVarArray(varPtr)) {
924     msg = isArray;
925     } else {
926     msg = noSuchVar;
927     }
928     VarErrMsg(interp, arrayName, elem, "read", msg);
929     }
930    
931     /*
932     * An error. If the variable doesn't exist anymore and no-one's using
933     * it, then free up the relevant structures and hash table entries.
934     */
935    
936     errorReturn:
937     if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) {
938     CleanupVar(varPtr, NULL); /* the array is not in a hashtable */
939     }
940     return NULL;
941     }
942    
943     /*
944     *----------------------------------------------------------------------
945     *
946     * Tcl_SetObjCmd --
947     *
948     * This procedure is invoked to process the "set" Tcl command.
949     * See the user documentation for details on what it does.
950     *
951     * Results:
952     * A standard Tcl result value.
953     *
954     * Side effects:
955     * A variable's value may be changed.
956     *
957     *----------------------------------------------------------------------
958     */
959    
960     /* ARGSUSED */
961     int
962     Tcl_SetObjCmd(dummy, interp, objc, objv)
963     ClientData dummy; /* Not used. */
964     register Tcl_Interp *interp; /* Current interpreter. */
965     int objc; /* Number of arguments. */
966     Tcl_Obj *CONST objv[]; /* Argument objects. */
967     {
968     Tcl_Obj *varValueObj;
969    
970     if (objc == 2) {
971     varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
972     if (varValueObj == NULL) {
973     return TCL_ERROR;
974     }
975     Tcl_SetObjResult(interp, varValueObj);
976     return TCL_OK;
977     } else if (objc == 3) {
978    
979     varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2],
980     TCL_LEAVE_ERR_MSG);
981     if (varValueObj == NULL) {
982     return TCL_ERROR;
983     }
984     Tcl_SetObjResult(interp, varValueObj);
985     return TCL_OK;
986     } else {
987     Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
988     return TCL_ERROR;
989     }
990     }
991    
992     /*
993     *----------------------------------------------------------------------
994     *
995     * Tcl_SetVar --
996     *
997     * Change the value of a variable.
998     *
999     * Results:
1000     * Returns a pointer to the malloc'ed string which is the character
1001     * representation of the variable's new value. The caller must not
1002     * modify this string. If the write operation was disallowed then NULL
1003     * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an
1004     * explanatory message will be left in the interp's result. Note that the
1005     * returned string may not be the same as newValue; this is because
1006     * variable traces may modify the variable's value.
1007     *
1008     * Side effects:
1009     * If varName is defined as a local or global variable in interp,
1010     * its value is changed to newValue. If varName isn't currently
1011     * defined, then a new global variable by that name is created.
1012     *
1013     *----------------------------------------------------------------------
1014     */
1015    
1016     char *
1017     Tcl_SetVar(interp, varName, newValue, flags)
1018     Tcl_Interp *interp; /* Command interpreter in which varName is
1019     * to be looked up. */
1020     char *varName; /* Name of a variable in interp. */
1021     char *newValue; /* New value for varName. */
1022     int flags; /* Various flags that tell how to set value:
1023     * any of TCL_GLOBAL_ONLY,
1024     * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1025     * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
1026     {
1027     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
1028     }
1029    
1030     /*
1031     *----------------------------------------------------------------------
1032     *
1033     * Tcl_SetVar2 --
1034     *
1035     * Given a two-part variable name, which may refer either to a
1036     * scalar variable or an element of an array, change the value
1037     * of the variable. If the named scalar or array or element
1038     * doesn't exist then create one.
1039     *
1040     * Results:
1041     * Returns a pointer to the malloc'ed string which is the character
1042     * representation of the variable's new value. The caller must not
1043     * modify this string. If the write operation was disallowed because an
1044     * array was expected but not found (or vice versa), then NULL is
1045     * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
1046     * message will be left in the interp's result. Note that the returned
1047     * string may not be the same as newValue; this is because variable
1048     * traces may modify the variable's value.
1049     *
1050     * Side effects:
1051     * The value of the given variable is set. If either the array
1052     * or the entry didn't exist then a new one is created.
1053     *
1054     *----------------------------------------------------------------------
1055     */
1056    
1057     char *
1058     Tcl_SetVar2(interp, part1, part2, newValue, flags)
1059     Tcl_Interp *interp; /* Command interpreter in which variable is
1060     * to be looked up. */
1061     char *part1; /* If part2 is NULL, this is name of scalar
1062     * variable. Otherwise it is the name of
1063     * an array. */
1064     char *part2; /* Name of an element within an array, or
1065     * NULL. */
1066     char *newValue; /* New value for variable. */
1067     int flags; /* Various flags that tell how to set value:
1068     * any of TCL_GLOBAL_ONLY,
1069     * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1070     * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */
1071     {
1072     register Tcl_Obj *valuePtr;
1073     Tcl_Obj *varValuePtr;
1074    
1075     /*
1076     * Create an object holding the variable's new value and use
1077     * Tcl_SetVar2Ex to actually set the variable.
1078     */
1079    
1080     valuePtr = Tcl_NewStringObj(newValue, -1);
1081     Tcl_IncrRefCount(valuePtr);
1082    
1083     varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags);
1084     Tcl_DecrRefCount(valuePtr); /* done with the object */
1085    
1086     if (varValuePtr == NULL) {
1087     return NULL;
1088     }
1089     return TclGetString(varValuePtr);
1090     }
1091    
1092     /*
1093     *----------------------------------------------------------------------
1094     *
1095     * Tcl_ObjSetVar2 --
1096     *
1097     * This function is the same as Tcl_SetVar2Ex below, except the
1098     * variable names are passed in Tcl object instead of strings.
1099     *
1100     * Results:
1101     * Returns a pointer to the Tcl_Obj holding the new value of the
1102     * variable. If the write operation was disallowed because an array was
1103     * expected but not found (or vice versa), then NULL is returned; if
1104     * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
1105     * be left in the interpreter's result. Note that the returned object
1106     * may not be the same one referenced by newValuePtr; this is because
1107     * variable traces may modify the variable's value.
1108     *
1109     * Side effects:
1110     * The value of the given variable is set. If either the array or the
1111     * entry didn't exist then a new variable is created.
1112    
1113     *
1114     *----------------------------------------------------------------------
1115     */
1116    
1117     Tcl_Obj *
1118     Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
1119     Tcl_Interp *interp; /* Command interpreter in which variable is
1120     * to be found. */
1121     register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
1122     * an array (if part2 is non-NULL) or the
1123     * name of a variable. */
1124     register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
1125     * the name of an element in the array
1126     * part1Ptr. */
1127     Tcl_Obj *newValuePtr; /* New value for variable. */
1128     int flags; /* Various flags that tell how to set value:
1129     * any of TCL_GLOBAL_ONLY,
1130     * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1131     * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or
1132     * TCL_PARSE_PART1. */
1133     {
1134     char *part1, *part2;
1135    
1136     part1 = Tcl_GetString(part1Ptr);
1137     if (part2Ptr != NULL) {
1138     part2 = Tcl_GetString(part2Ptr);
1139     } else {
1140     part2 = NULL;
1141     }
1142    
1143     return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags);
1144     }
1145    
1146     /*
1147     *----------------------------------------------------------------------
1148     *
1149     * Tcl_SetVar2Ex --
1150     *
1151     * Given a two-part variable name, which may refer either to a scalar
1152     * variable or an element of an array, change the value of the variable
1153     * to a new Tcl object value. If the named scalar or array or element
1154     * doesn't exist then create one.
1155     *
1156     * Results:
1157     * Returns a pointer to the Tcl_Obj holding the new value of the
1158     * variable. If the write operation was disallowed because an array was
1159     * expected but not found (or vice versa), then NULL is returned; if
1160     * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
1161     * be left in the interpreter's result. Note that the returned object
1162     * may not be the same one referenced by newValuePtr; this is because
1163     * variable traces may modify the variable's value.
1164     *
1165     * Side effects:
1166     * The value of the given variable is set. If either the array or the
1167     * entry didn't exist then a new variable is created.
1168     *
1169     * The reference count is decremented for any old value of the variable
1170     * and incremented for its new value. If the new value for the variable
1171     * is not the same one referenced by newValuePtr (perhaps as a result
1172     * of a variable trace), then newValuePtr's ref count is left unchanged
1173     * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if
1174     * we are appending it as a string value: that is, if "flags" includes
1175     * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT.
1176     *
1177     * The reference count for the returned object is _not_ incremented: if
1178     * you want to keep a reference to the object you must increment its
1179     * ref count yourself.
1180     *
1181     *----------------------------------------------------------------------
1182     */
1183    
1184     Tcl_Obj *
1185     Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
1186     Tcl_Interp *interp; /* Command interpreter in which variable is
1187     * to be found. */
1188     char *part1; /* Name of an array (if part2 is non-NULL)
1189     * or the name of a variable. */
1190     char *part2; /* If non-NULL, gives the name of an element
1191     * in the array part1. */
1192     Tcl_Obj *newValuePtr; /* New value for variable. */
1193     int flags; /* Various flags that tell how to set value:
1194     * any of TCL_GLOBAL_ONLY,
1195     * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1196     * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
1197     {
1198     Interp *iPtr = (Interp *) interp;
1199     register Var *varPtr;
1200     Var *arrayPtr;
1201     Tcl_Obj *oldValuePtr;
1202     Tcl_Obj *resultPtr = NULL;
1203     char *bytes;
1204     int length, result;
1205    
1206     varPtr = TclLookupVar(interp, part1, part2, flags, "set",
1207     /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
1208     if (varPtr == NULL) {
1209     return NULL;
1210     }
1211    
1212     /*
1213     * If the variable is in a hashtable and its hPtr field is NULL, then we
1214     * may have an upvar to an array element where the array was deleted
1215     * or an upvar to a namespace variable whose namespace was deleted.
1216     * Generate an error (allowing the variable to be reset would screw up
1217     * our storage allocation and is meaningless anyway).
1218     */
1219    
1220     if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
1221     if (flags & TCL_LEAVE_ERR_MSG) {
1222     if (TclIsVarArrayElement(varPtr)) {
1223     VarErrMsg(interp, part1, part2, "set", danglingElement);
1224     } else {
1225     VarErrMsg(interp, part1, part2, "set", danglingVar);
1226     }
1227     }
1228     return NULL;
1229     }
1230    
1231     /*
1232     * It's an error to try to set an array variable itself.
1233     */
1234    
1235     if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
1236     if (flags & TCL_LEAVE_ERR_MSG) {
1237     VarErrMsg(interp, part1, part2, "set", isArray);
1238     }
1239     return NULL;
1240     }
1241    
1242     /*
1243     * At this point, if we were appending, we used to call read traces: we
1244     * treated append as a read-modify-write. However, it seemed unlikely to
1245     * us that a real program would be interested in such reads being done
1246     * during a set operation.
1247     */
1248    
1249     /*
1250     * Set the variable's new value. If appending, append the new value to
1251     * the variable, either as a list element or as a string. Also, if
1252     * appending, then if the variable's old value is unshared we can modify
1253     * it directly, otherwise we must create a new copy to modify: this is
1254     * "copy on write".
1255     */
1256    
1257     oldValuePtr = varPtr->value.objPtr;
1258     if (flags & TCL_APPEND_VALUE) {
1259     if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
1260     Tcl_DecrRefCount(oldValuePtr); /* discard old value */
1261     varPtr->value.objPtr = NULL;
1262     oldValuePtr = NULL;
1263     }
1264     if (flags & TCL_LIST_ELEMENT) { /* append list element */
1265     if (oldValuePtr == NULL) {
1266     TclNewObj(oldValuePtr);
1267     varPtr->value.objPtr = oldValuePtr;
1268     Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
1269     } else if (Tcl_IsShared(oldValuePtr)) {
1270     varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
1271     Tcl_DecrRefCount(oldValuePtr);
1272     oldValuePtr = varPtr->value.objPtr;
1273     Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */
1274     }
1275     result = Tcl_ListObjAppendElement(interp, oldValuePtr,
1276     newValuePtr);
1277     if (result != TCL_OK) {
1278     return NULL;
1279     }
1280     } else { /* append string */
1281     /*
1282     * We append newValuePtr's bytes but don't change its ref count.
1283     */
1284    
1285     bytes = Tcl_GetStringFromObj(newValuePtr, &length);
1286     if (oldValuePtr == NULL) {
1287     varPtr->value.objPtr = Tcl_NewStringObj(bytes, length);
1288     Tcl_IncrRefCount(varPtr->value.objPtr);
1289     } else {
1290     if (Tcl_IsShared(oldValuePtr)) { /* append to copy */
1291     varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr);
1292     TclDecrRefCount(oldValuePtr);
1293     oldValuePtr = varPtr->value.objPtr;
1294     Tcl_IncrRefCount(oldValuePtr); /* since var is ref */
1295     }
1296     Tcl_AppendObjToObj(oldValuePtr, newValuePtr);
1297     }
1298     }
1299     } else {
1300     if (flags & TCL_LIST_ELEMENT) { /* set var to list element */
1301     int neededBytes, listFlags;
1302    
1303     /*
1304     * We set the variable to the result of converting newValuePtr's
1305     * string rep to a list element. We do not change newValuePtr's
1306     * ref count.
1307     */
1308    
1309     if (oldValuePtr != NULL) {
1310     Tcl_DecrRefCount(oldValuePtr); /* discard old value */
1311     }
1312     bytes = Tcl_GetStringFromObj(newValuePtr, &length);
1313     neededBytes = Tcl_ScanElement(bytes, &listFlags);
1314     oldValuePtr = Tcl_NewObj();
1315     oldValuePtr->bytes = (char *)
1316     ckalloc((unsigned) (neededBytes + 1));
1317     oldValuePtr->length = Tcl_ConvertElement(bytes,
1318     oldValuePtr->bytes, listFlags);
1319     varPtr->value.objPtr = oldValuePtr;
1320     Tcl_IncrRefCount(varPtr->value.objPtr);
1321     } else if (newValuePtr != oldValuePtr) {
1322     varPtr->value.objPtr = newValuePtr;
1323     Tcl_IncrRefCount(newValuePtr); /* var is another ref */
1324     if (oldValuePtr != NULL) {
1325     TclDecrRefCount(oldValuePtr); /* discard old value */
1326     }
1327     }
1328     }
1329     TclSetVarScalar(varPtr);
1330     TclClearVarUndefined(varPtr);
1331     if (arrayPtr != NULL) {
1332     TclClearVarUndefined(arrayPtr);
1333     }
1334    
1335     /*
1336     * Invoke any write traces for the variable.
1337     */
1338    
1339     if ((varPtr->tracePtr != NULL)
1340     || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1341     char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
1342     (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES);
1343     if (msg != NULL) {
1344     if (flags & TCL_LEAVE_ERR_MSG) {
1345     VarErrMsg(interp, part1, part2, "set", msg);
1346     }
1347     goto cleanup;
1348     }
1349     }
1350    
1351     /*
1352     * Return the variable's value unless the variable was changed in some
1353     * gross way by a trace (e.g. it was unset and then recreated as an
1354     * array).
1355     */
1356    
1357     if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
1358     return varPtr->value.objPtr;
1359     }
1360    
1361     /*
1362     * A trace changed the value in some gross way. Return an empty string
1363     * object.
1364     */
1365    
1366     resultPtr = iPtr->emptyObjPtr;
1367    
1368     /*
1369     * If the variable doesn't exist anymore and no-one's using it, then
1370     * free up the relevant structures and hash table entries.
1371     */
1372    
1373     cleanup:
1374     if (TclIsVarUndefined(varPtr)) {
1375     CleanupVar(varPtr, arrayPtr);
1376     }
1377     return resultPtr;
1378     }
1379    
1380     /*
1381     *----------------------------------------------------------------------
1382     *
1383     * TclSetIndexedScalar --
1384     *
1385     * Change the Tcl object value of a local scalar variable in the active
1386     * procedure, given its compile-time allocated index in the procedure's
1387     * array of local variables.
1388     *
1389     * Results:
1390     * Returns a pointer to the Tcl_Obj holding the new value of the
1391     * variable given by localIndex. If the specified variable doesn't
1392     * exist, or there is a clash in array usage, or an error occurs while
1393     * executing variable traces, then NULL is returned and a message will
1394     * be left in the interpreter's result if leaveErrorMsg is 1. Note
1395     * that the returned object may not be the same one referenced by
1396     * newValuePtr; this is because variable traces may modify the
1397     * variable's value.
1398     *
1399     * Side effects:
1400     * The value of the given variable is set. The reference count is
1401     * decremented for any old value of the variable and incremented for
1402     * its new value. If as a result of a variable trace the new value for
1403     * the variable is not the same one referenced by newValuePtr, then
1404     * newValuePtr's ref count is left unchanged. The ref count for the
1405     * returned object is _not_ incremented to reflect the returned
1406     * reference; if you want to keep a reference to the object you must
1407     * increment its ref count yourself. This procedure does not create
1408     * new variables, but only sets those recognized at compile time.
1409     *
1410     *----------------------------------------------------------------------
1411     */
1412    
1413     Tcl_Obj *
1414     TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg)
1415     Tcl_Interp *interp; /* Command interpreter in which variable is
1416     * to be found. */
1417     int localIndex; /* Index of variable in procedure's array
1418     * of local variables. */
1419     Tcl_Obj *newValuePtr; /* New value for variable. */
1420     int leaveErrorMsg; /* 1 if to leave an error message in
1421     * the interpreter's result on an error.
1422     * Otherwise no error message is left. */
1423     {
1424     Interp *iPtr = (Interp *) interp;
1425     CallFrame *varFramePtr = iPtr->varFramePtr;
1426     /* Points to the procedure call frame whose
1427     * variables are currently in use. Same as
1428     * the current procedure's frame, if any,
1429     * unless an "uplevel" is executing. */
1430     Var *compiledLocals = varFramePtr->compiledLocals;
1431     register Var *varPtr; /* Points to the variable's in-frame Var
1432     * structure. */
1433     char *varName; /* Name of the local variable. */
1434     Tcl_Obj *oldValuePtr;
1435     Tcl_Obj *resultPtr = NULL;
1436    
1437     #ifdef TCL_COMPILE_DEBUG
1438     Proc *procPtr = varFramePtr->procPtr;
1439     int localCt = procPtr->numCompiledLocals;
1440    
1441     if (compiledLocals == NULL) {
1442     fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n",
1443     localIndex, (unsigned int) varFramePtr);
1444     panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
1445     (unsigned int) varFramePtr);
1446     }
1447     if ((localIndex < 0) || (localIndex >= localCt)) {
1448     fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n",
1449     localIndex, (unsigned int) varFramePtr, localCt);
1450     panic("TclSetIndexedScalar: bad local index %i in frame 0x%x",
1451     localIndex, (unsigned int) varFramePtr);
1452     }
1453     #endif /* TCL_COMPILE_DEBUG */
1454    
1455     varPtr = &(compiledLocals[localIndex]);
1456     varName = varPtr->name;
1457    
1458     /*
1459     * If varPtr is a link variable, we have a reference to some variable
1460     * that was created through an "upvar" or "global" command, or we have a
1461     * reference to a variable in an enclosing namespace. Traverse through
1462     * any links until we find the referenced variable.
1463     */
1464    
1465     while (TclIsVarLink(varPtr)) {
1466     varPtr = varPtr->value.linkPtr;
1467     }
1468    
1469     /*
1470     * If the variable is in a hashtable and its hPtr field is NULL, then we
1471     * may have an upvar to an array element where the array was deleted
1472     * or an upvar to a namespace variable whose namespace was deleted.
1473     * Generate an error (allowing the variable to be reset would screw up
1474     * our storage allocation and is meaningless anyway).
1475     */
1476    
1477     if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) {
1478     if (leaveErrorMsg) {
1479     if (TclIsVarArrayElement(varPtr)) {
1480     VarErrMsg(interp, varName, NULL, "set", danglingElement);
1481     } else {
1482     VarErrMsg(interp, varName, NULL, "set", danglingVar);
1483     }
1484     }
1485     return NULL;
1486     }
1487    
1488     /*
1489     * It's an error to try to set an array variable itself.
1490     */
1491    
1492     if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
1493     if (leaveErrorMsg) {
1494     VarErrMsg(interp, varName, NULL, "set", isArray);
1495     }
1496     return NULL;
1497     }
1498    
1499     /*
1500     * Set the variable's new value and discard its old value. We don't
1501     * append with this "set" procedure so the old value isn't needed.
1502     */
1503    
1504     oldValuePtr = varPtr->value.objPtr;
1505     if (newValuePtr != oldValuePtr) { /* set new value */
1506     varPtr->value.objPtr = newValuePtr;
1507     Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
1508     if (oldValuePtr != NULL) {
1509     TclDecrRefCount(oldValuePtr); /* discard old value */
1510     }
1511     }
1512     TclSetVarScalar(varPtr);
1513     TclClearVarUndefined(varPtr);
1514    
1515     /*
1516     * Invoke any write traces for the variable.
1517     */
1518    
1519     if (varPtr->tracePtr != NULL) {
1520     char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr,
1521     varName, (char *) NULL, TCL_TRACE_WRITES);
1522     if (msg != NULL) {
1523     if (leaveErrorMsg) {
1524     VarErrMsg(interp, varName, NULL, "set", msg);
1525     }
1526     goto cleanup;
1527     }
1528     }
1529    
1530     /*
1531     * Return the variable's value unless the variable was changed in some
1532     * gross way by a trace (e.g. it was unset and then recreated as an
1533     * array). If it was changed is a gross way, just return an empty string
1534     * object.
1535     */
1536    
1537     if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
1538     return varPtr->value.objPtr;
1539     }
1540    
1541     resultPtr = Tcl_NewObj();
1542    
1543     /*
1544     * If the variable doesn't exist anymore and no-one's using it, then
1545     * free up the relevant structures and hash table entries.
1546     */
1547    
1548     cleanup:
1549     if (TclIsVarUndefined(varPtr)) {
1550     CleanupVar(varPtr, NULL);
1551     }
1552     return resultPtr;
1553     }
1554    
1555     /*
1556     *----------------------------------------------------------------------
1557     *
1558     * TclSetElementOfIndexedArray --
1559     *
1560     * Change the Tcl object value of an element in a local array
1561     * variable. The element is named by the object elemPtr while the array
1562     * is specified by its index in the active procedure's array of
1563     * compiler allocated local variables.
1564     *
1565     * Results:
1566     * Returns a pointer to the Tcl_Obj holding the new value of the
1567     * element. If the specified array or element doesn't exist, or there
1568     * is a clash in array usage, or an error occurs while executing
1569     * variable traces, then NULL is returned and a message will be left in
1570     * the interpreter's result if leaveErrorMsg is 1. Note that the
1571     * returned object may not be the same one referenced by newValuePtr;
1572     * this is because variable traces may modify the variable's value.
1573     *
1574     * Side effects:
1575     * The value of the given array element is set. The reference count is
1576     * decremented for any old value of the element and incremented for its
1577     * new value. If as a result of a variable trace the new value for the
1578     * element is not the same one referenced by newValuePtr, then
1579     * newValuePtr's ref count is left unchanged. The ref count for the
1580     * returned object is _not_ incremented to reflect the returned
1581     * reference; if you want to keep a reference to the object you must
1582     * increment its ref count yourself. This procedure will not create new
1583     * array variables, but only sets elements of those arrays recognized
1584     * at compile time. However, if the entry doesn't exist then a new
1585     * variable is created.
1586     *
1587     *----------------------------------------------------------------------
1588     */
1589    
1590     Tcl_Obj *
1591     TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr,
1592     leaveErrorMsg)
1593     Tcl_Interp *interp; /* Command interpreter in which the array is
1594     * to be found. */
1595     int localIndex; /* Index of array variable in procedure's
1596     * array of local variables. */
1597     Tcl_Obj *elemPtr; /* Points to an object holding the name of
1598     * an element to set in the array. */
1599     Tcl_Obj *newValuePtr; /* New value for variable. */
1600     int leaveErrorMsg; /* 1 if to leave an error message in
1601     * the interpreter's result on an error.
1602     * Otherwise no error message is left. */
1603     {
1604     Interp *iPtr = (Interp *) interp;
1605     CallFrame *varFramePtr = iPtr->varFramePtr;
1606     /* Points to the procedure call frame whose
1607     * variables are currently in use. Same as
1608     * the current procedure's frame, if any,
1609     * unless an "uplevel" is executing. */
1610     Var *compiledLocals = varFramePtr->compiledLocals;
1611     Var *arrayPtr; /* Points to the array's in-frame Var
1612     * structure. */
1613     char *arrayName; /* Name of the local array. */
1614     char *elem;
1615     Tcl_HashEntry *hPtr;
1616     Var *varPtr = NULL; /* Points to the element's Var structure
1617     * that we return. */
1618     Tcl_Obj *resultPtr = NULL;
1619     Tcl_Obj *oldValuePtr;
1620     int new;
1621    
1622     #ifdef TCL_COMPILE_DEBUG
1623     Proc *procPtr = varFramePtr->procPtr;
1624     int localCt = procPtr->numCompiledLocals;
1625    
1626     if (compiledLocals == NULL) {
1627     fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n",
1628     localIndex, (unsigned int) varFramePtr);
1629     panic("TclSetIndexedScalar: no compiled locals in frame 0x%x",
1630     (unsigned int) varFramePtr);
1631     }
1632     if ((localIndex < 0) || (localIndex >= localCt)) {
1633     fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n",
1634     localIndex, (unsigned int) varFramePtr, localCt);
1635     panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x",
1636     localIndex, (unsigned int) varFramePtr);
1637     }
1638     #endif /* TCL_COMPILE_DEBUG */
1639    
1640     elem = TclGetString(elemPtr);
1641     arrayPtr = &(compiledLocals[localIndex]);
1642     arrayName = arrayPtr->name;
1643    
1644     /*
1645     * If arrayPtr is a link variable, we have a reference to some variable
1646     * that was created through an "upvar" or "global" command, or we have a
1647     * reference to a variable in an enclosing namespace. Traverse through
1648     * any links until we find the referenced variable.
1649     */
1650    
1651     while (TclIsVarLink(arrayPtr)) {
1652     arrayPtr = arrayPtr->value.linkPtr;
1653     }
1654    
1655     /*
1656     * If the variable is in a hashtable and its hPtr field is NULL, then we
1657     * may have an upvar to an array element where the array was deleted
1658     * or an upvar to a namespace variable whose namespace was deleted.
1659     * Generate an error (allowing the variable to be reset would screw up
1660     * our storage allocation and is meaningless anyway).
1661     */
1662    
1663     if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
1664     if (leaveErrorMsg) {
1665     if (TclIsVarArrayElement(arrayPtr)) {
1666     VarErrMsg(interp, arrayName, elem, "set", danglingElement);
1667     } else {
1668     VarErrMsg(interp, arrayName, elem, "set", danglingVar);
1669     }
1670     }
1671     goto errorReturn;
1672     }
1673    
1674     /*
1675     * Make sure we're dealing with an array.
1676     */
1677    
1678     if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
1679     TclSetVarArray(arrayPtr);
1680     arrayPtr->value.tablePtr =
1681     (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
1682     Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
1683     TclClearVarUndefined(arrayPtr);
1684     } else if (!TclIsVarArray(arrayPtr)) {
1685     if (leaveErrorMsg) {
1686     VarErrMsg(interp, arrayName, elem, "set", needArray);
1687     }
1688     goto errorReturn;
1689     }
1690    
1691     /*
1692     * Look up the element.
1693     */
1694    
1695     hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
1696     if (new) {
1697     if (arrayPtr->searchPtr != NULL) {
1698     DeleteSearches(arrayPtr);
1699     }
1700     varPtr = NewVar();
1701     Tcl_SetHashValue(hPtr, varPtr);
1702     varPtr->hPtr = hPtr;
1703     varPtr->nsPtr = varFramePtr->nsPtr;
1704     TclSetVarArrayElement(varPtr);
1705     }
1706     varPtr = (Var *) Tcl_GetHashValue(hPtr);
1707    
1708     /*
1709     * It's an error to try to set an array variable itself.
1710     */
1711    
1712     if (TclIsVarArray(varPtr)) {
1713     if (leaveErrorMsg) {
1714     VarErrMsg(interp, arrayName, elem, "set", isArray);
1715     }
1716     goto errorReturn;
1717     }
1718    
1719     /*
1720     * Set the variable's new value and discard the old one. We don't
1721     * append with this "set" procedure so the old value isn't needed.
1722     */
1723    
1724     oldValuePtr = varPtr->value.objPtr;
1725     if (newValuePtr != oldValuePtr) { /* set new value */
1726     varPtr->value.objPtr = newValuePtr;
1727     Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */
1728     if (oldValuePtr != NULL) {
1729     TclDecrRefCount(oldValuePtr); /* discard old value */
1730     }
1731     }
1732     TclSetVarScalar(varPtr);
1733     TclClearVarUndefined(varPtr);
1734    
1735     /*
1736     * Invoke any write traces for the element variable.
1737     */
1738    
1739     if ((varPtr->tracePtr != NULL)
1740     || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
1741     char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
1742     TCL_TRACE_WRITES);
1743     if (msg != NULL) {
1744     if (leaveErrorMsg) {
1745     VarErrMsg(interp, arrayName, elem, "set", msg);
1746     }
1747     goto errorReturn;
1748     }
1749     }
1750    
1751     /*
1752     * Return the element's value unless it was changed in some gross way by
1753     * a trace (e.g. it was unset and then recreated as an array). If it was
1754     * changed is a gross way, just return an empty string object.
1755     */
1756    
1757     if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) {
1758     return varPtr->value.objPtr;
1759     }
1760    
1761     resultPtr = Tcl_NewObj();
1762    
1763     /*
1764     * An error. If the variable doesn't exist anymore and no-one's using
1765     * it, then free up the relevant structures and hash table entries.
1766     */
1767    
1768     errorReturn:
1769     if (varPtr != NULL) {
1770     if (TclIsVarUndefined(varPtr)) {
1771     CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */
1772     }
1773     }
1774     return resultPtr;
1775     }
1776    
1777     /*
1778     *----------------------------------------------------------------------
1779     *
1780     * TclIncrVar2 --
1781     *
1782     * Given a two-part variable name, which may refer either to a scalar
1783     * variable or an element of an array, increment the Tcl object value
1784     * of the variable by a specified amount.
1785     *
1786     * Results:
1787     * Returns a pointer to the Tcl_Obj holding the new value of the
1788     * variable. If the specified variable doesn't exist, or there is a
1789     * clash in array usage, or an error occurs while executing variable
1790     * traces, then NULL is returned and a message will be left in
1791     * the interpreter's result.
1792     *
1793     * Side effects:
1794     * The value of the given variable is incremented by the specified
1795     * amount. If either the array or the entry didn't exist then a new
1796     * variable is created. The ref count for the returned object is _not_
1797     * incremented to reflect the returned reference; if you want to keep a
1798     * reference to the object you must increment its ref count yourself.
1799     *
1800     *----------------------------------------------------------------------
1801     */
1802    
1803     Tcl_Obj *
1804     TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags)
1805     Tcl_Interp *interp; /* Command interpreter in which variable is
1806     * to be found. */
1807     Tcl_Obj *part1Ptr; /* Points to an object holding the name of
1808     * an array (if part2 is non-NULL) or the
1809     * name of a variable. */
1810     Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
1811     * the name of an element in the array
1812     * part1Ptr. */
1813     long incrAmount; /* Amount to be added to variable. */
1814     int flags; /* Various flags that tell how to incr value:
1815     * any of TCL_GLOBAL_ONLY,
1816     * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
1817     * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
1818     {
1819     register Tcl_Obj *varValuePtr;
1820     Tcl_Obj *resultPtr;
1821     int createdNewObj; /* Set 1 if var's value object is shared
1822     * so we must increment a copy (i.e. copy
1823     * on write). */
1824     long i;
1825     int result;
1826    
1827     varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
1828     if (varValuePtr == NULL) {
1829     Tcl_AddObjErrorInfo(interp,
1830     "\n (reading value of variable to increment)", -1);
1831     return NULL;
1832     }
1833    
1834     /*
1835     * Increment the variable's value. If the object is unshared we can
1836     * modify it directly, otherwise we must create a new copy to modify:
1837     * this is "copy on write". Then free the variable's old string
1838     * representation, if any, since it will no longer be valid.
1839     */
1840    
1841     createdNewObj = 0;
1842     if (Tcl_IsShared(varValuePtr)) {
1843     varValuePtr = Tcl_DuplicateObj(varValuePtr);
1844     createdNewObj = 1;
1845     }
1846     result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
1847     if (result != TCL_OK) {
1848     if (createdNewObj) {
1849     Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
1850     }
1851     return NULL;
1852     }
1853     Tcl_SetLongObj(varValuePtr, (i + incrAmount));
1854    
1855     /*
1856     * Store the variable's new value and run any write traces.
1857     */
1858    
1859     resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags);
1860     if (resultPtr == NULL) {
1861     return NULL;
1862     }
1863     return resultPtr;
1864     }
1865    
1866     /*
1867     *----------------------------------------------------------------------
1868     *
1869     * TclIncrIndexedScalar --
1870     *
1871     * Increments the Tcl object value of a local scalar variable in the
1872     * active procedure, given its compile-time allocated index in the
1873     * procedure's array of local variables.
1874     *
1875     * Results:
1876     * Returns a pointer to the Tcl_Obj holding the new value of the
1877     * variable given by localIndex. If the specified variable doesn't
1878     * exist, or there is a clash in array usage, or an error occurs while
1879     * executing variable traces, then NULL is returned and a message will
1880     * be left in the interpreter's result.
1881     *
1882     * Side effects:
1883     * The value of the given variable is incremented by the specified
1884     * amount. The ref count for the returned object is _not_ incremented
1885     * to reflect the returned reference; if you want to keep a reference
1886     * to the object you must increment its ref count yourself.
1887     *
1888     *----------------------------------------------------------------------
1889     */
1890    
1891     Tcl_Obj *
1892     TclIncrIndexedScalar(interp, localIndex, incrAmount)
1893     Tcl_Interp *interp; /* Command interpreter in which variable is
1894     * to be found. */
1895     int localIndex; /* Index of variable in procedure's array
1896     * of local variables. */
1897     long incrAmount; /* Amount to be added to variable. */
1898     {
1899     register Tcl_Obj *varValuePtr;
1900     Tcl_Obj *resultPtr;
1901     int createdNewObj; /* Set 1 if var's value object is shared
1902     * so we must increment a copy (i.e. copy
1903     * on write). */
1904     long i;
1905     int result;
1906    
1907     varValuePtr = TclGetIndexedScalar(interp, localIndex,
1908     /*leaveErrorMsg*/ 1);
1909     if (varValuePtr == NULL) {
1910     Tcl_AddObjErrorInfo(interp,
1911     "\n (reading value of variable to increment)", -1);
1912     return NULL;
1913     }
1914    
1915     /*
1916     * Reach into the object's representation to extract and increment the
1917     * variable's value. If the object is unshared we can modify it
1918     * directly, otherwise we must create a new copy to modify: this is
1919     * "copy on write". Then free the variable's old string representation,
1920     * if any, since it will no longer be valid.
1921     */
1922    
1923     createdNewObj = 0;
1924     if (Tcl_IsShared(varValuePtr)) {
1925     createdNewObj = 1;
1926     varValuePtr = Tcl_DuplicateObj(varValuePtr);
1927     }
1928     result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
1929     if (result != TCL_OK) {
1930     if (createdNewObj) {
1931     Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
1932     }
1933     return NULL;
1934     }
1935     Tcl_SetLongObj(varValuePtr, (i + incrAmount));
1936    
1937     /*
1938     * Store the variable's new value and run any write traces.
1939     */
1940    
1941     resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr,
1942     /*leaveErrorMsg*/ 1);
1943     if (resultPtr == NULL) {
1944     return NULL;
1945     }
1946     return resultPtr;
1947     }
1948    
1949     /*
1950     *----------------------------------------------------------------------
1951     *
1952     * TclIncrElementOfIndexedArray --
1953     *
1954     * Increments the Tcl object value of an element in a local array
1955     * variable. The element is named by the object elemPtr while the array
1956     * is specified by its index in the active procedure's array of
1957     * compiler allocated local variables.
1958     *
1959     * Results:
1960     * Returns a pointer to the Tcl_Obj holding the new value of the
1961     * element. If the specified array or element doesn't exist, or there
1962     * is a clash in array usage, or an error occurs while executing
1963     * variable traces, then NULL is returned and a message will be left in
1964     * the interpreter's result.
1965     *
1966     * Side effects:
1967     * The value of the given array element is incremented by the specified
1968     * amount. The ref count for the returned object is _not_ incremented
1969     * to reflect the returned reference; if you want to keep a reference
1970     * to the object you must increment its ref count yourself. If the
1971     * entry doesn't exist then a new variable is created.
1972     *
1973     *----------------------------------------------------------------------
1974     */
1975    
1976     Tcl_Obj *
1977     TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount)
1978     Tcl_Interp *interp; /* Command interpreter in which the array is
1979     * to be found. */
1980     int localIndex; /* Index of array variable in procedure's
1981     * array of local variables. */
1982     Tcl_Obj *elemPtr; /* Points to an object holding the name of
1983     * an element to increment in the array. */
1984     long incrAmount; /* Amount to be added to variable. */
1985     {
1986     register Tcl_Obj *varValuePtr;
1987     Tcl_Obj *resultPtr;
1988     int createdNewObj; /* Set 1 if var's value object is shared
1989     * so we must increment a copy (i.e. copy
1990     * on write). */
1991     long i;
1992     int result;
1993    
1994     varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr,
1995     /*leaveErrorMsg*/ 1);
1996     if (varValuePtr == NULL) {
1997     Tcl_AddObjErrorInfo(interp,
1998     "\n (reading value of variable to increment)", -1);
1999     return NULL;
2000     }
2001    
2002     /*
2003     * Reach into the object's representation to extract and increment the
2004     * variable's value. If the object is unshared we can modify it
2005     * directly, otherwise we must create a new copy to modify: this is
2006     * "copy on write". Then free the variable's old string representation,
2007     * if any, since it will no longer be valid.
2008     */
2009    
2010     createdNewObj = 0;
2011     if (Tcl_IsShared(varValuePtr)) {
2012     createdNewObj = 1;
2013     varValuePtr = Tcl_DuplicateObj(varValuePtr);
2014     }
2015     result = Tcl_GetLongFromObj(interp, varValuePtr, &i);
2016     if (result != TCL_OK) {
2017     if (createdNewObj) {
2018     Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */
2019     }
2020     return NULL;
2021     }
2022     Tcl_SetLongObj(varValuePtr, (i + incrAmount));
2023    
2024     /*
2025     * Store the variable's new value and run any write traces.
2026     */
2027    
2028     resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr,
2029     varValuePtr,
2030     /*leaveErrorMsg*/ 1);
2031     if (resultPtr == NULL) {
2032     return NULL;
2033     }
2034     return resultPtr;
2035     }
2036    
2037     /*
2038     *----------------------------------------------------------------------
2039     *
2040     * Tcl_UnsetVar --
2041     *
2042     * Delete a variable, so that it may not be accessed anymore.
2043     *
2044     * Results:
2045     * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
2046     * if the variable can't be unset. In the event of an error,
2047     * if the TCL_LEAVE_ERR_MSG flag is set then an error message
2048     * is left in the interp's result.
2049     *
2050     * Side effects:
2051     * If varName is defined as a local or global variable in interp,
2052     * it is deleted.
2053     *
2054     *----------------------------------------------------------------------
2055     */
2056    
2057     int
2058     Tcl_UnsetVar(interp, varName, flags)
2059     Tcl_Interp *interp; /* Command interpreter in which varName is
2060     * to be looked up. */
2061     char *varName; /* Name of a variable in interp. May be
2062     * either a scalar name or an array name
2063     * or an element in an array. */
2064     int flags; /* OR-ed combination of any of
2065     * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
2066     * TCL_LEAVE_ERR_MSG. */
2067     {
2068     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
2069     }
2070    
2071     /*
2072     *----------------------------------------------------------------------
2073     *
2074     * Tcl_UnsetVar2 --
2075     *
2076     * Delete a variable, given a 2-part name.
2077     *
2078     * Results:
2079     * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
2080     * if the variable can't be unset. In the event of an error,
2081     * if the TCL_LEAVE_ERR_MSG flag is set then an error message
2082     * is left in the interp's result.
2083     *
2084     * Side effects:
2085     * If part1 and part2 indicate a local or global variable in interp,
2086     * it is deleted. If part1 is an array name and part2 is NULL, then
2087     * the whole array is deleted.
2088     *
2089     *----------------------------------------------------------------------
2090     */
2091    
2092     int
2093     Tcl_UnsetVar2(interp, part1, part2, flags)
2094     Tcl_Interp *interp; /* Command interpreter in which varName is
2095     * to be looked up. */
2096     char *part1; /* Name of variable or array. */
2097     char *part2; /* Name of element within array or NULL. */
2098     int flags; /* OR-ed combination of any of
2099     * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
2100     * TCL_LEAVE_ERR_MSG. */
2101     {
2102     Var dummyVar;
2103     Var *varPtr, *dummyVarPtr;
2104     Interp *iPtr = (Interp *) interp;
2105     Var *arrayPtr;
2106     ActiveVarTrace *activePtr;
2107     Tcl_Obj *objPtr;
2108     int result;
2109    
2110     varPtr = TclLookupVar(interp, part1, part2, flags, "unset",
2111     /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
2112     if (varPtr == NULL) {
2113     return TCL_ERROR;
2114     }
2115     result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
2116    
2117     if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
2118     DeleteSearches(arrayPtr);
2119     }
2120    
2121     /*
2122     * The code below is tricky, because of the possibility that
2123     * a trace procedure might try to access a variable being
2124     * deleted. To handle this situation gracefully, do things
2125     * in three steps:
2126     * 1. Copy the contents of the variable to a dummy variable
2127     * structure, and mark the original Var structure as undefined.
2128     * 2. Invoke traces and clean up the variable, using the dummy copy.
2129     * 3. If at the end of this the original variable is still
2130     * undefined and has no outstanding references, then delete
2131     * it (but it could have gotten recreated by a trace).
2132     */
2133    
2134     dummyVar = *varPtr;
2135     TclSetVarUndefined(varPtr);
2136     TclSetVarScalar(varPtr);
2137     varPtr->value.objPtr = NULL; /* dummyVar points to any value object */
2138     varPtr->tracePtr = NULL;
2139     varPtr->searchPtr = NULL;
2140    
2141     /*
2142     * Call trace procedures for the variable being deleted. Then delete
2143     * its traces. Be sure to abort any other traces for the variable
2144     * that are still pending. Special tricks:
2145     * 1. We need to increment varPtr's refCount around this: CallTraces
2146     * will use dummyVar so it won't increment varPtr's refCount itself.
2147     * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
2148     * call unset traces even if other traces are pending.
2149     */
2150    
2151     if ((dummyVar.tracePtr != NULL)
2152     || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
2153     varPtr->refCount++;
2154     dummyVar.flags &= ~VAR_TRACE_ACTIVE;
2155     (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
2156     (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
2157     while (dummyVar.tracePtr != NULL) {
2158     VarTrace *tracePtr = dummyVar.tracePtr;
2159     dummyVar.tracePtr = tracePtr->nextPtr;
2160     ckfree((char *) tracePtr);
2161     }
2162     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
2163     activePtr = activePtr->nextPtr) {
2164     if (activePtr->varPtr == varPtr) {
2165     activePtr->nextTracePtr = NULL;
2166     }
2167     }
2168     varPtr->refCount--;
2169     }
2170    
2171     /*
2172     * If the variable is an array, delete all of its elements. This must be
2173     * done after calling the traces on the array, above (that's the way
2174     * traces are defined). If it is a scalar, "discard" its object
2175     * (decrement the ref count of its object, if any).
2176     */
2177    
2178     dummyVarPtr = &dummyVar;
2179     if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
2180     /*
2181     * Deleting the elements of the array may cause traces to be fired
2182     * on those elements. Before deleting them, bump the reference count
2183     * of the array, so that if those trace procs make a global or upvar
2184     * link to the array, the array is not deleted when the call stack
2185     * gets popped (we will delete the array ourselves later in this
2186     * function).
2187     *
2188     * Bumping the count can lead to the odd situation that elements of the
2189     * array are being deleted when the array still exists, but since the
2190     * array is about to be removed anyway, that shouldn't really matter.
2191     */
2192     varPtr->refCount++;
2193     DeleteArray(iPtr, part1, dummyVarPtr,
2194     (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
2195     /* Decr ref count */
2196     varPtr->refCount--;
2197     }
2198     if (TclIsVarScalar(dummyVarPtr)
2199     && (dummyVarPtr->value.objPtr != NULL)) {
2200     objPtr = dummyVarPtr->value.objPtr;
2201     TclDecrRefCount(objPtr);
2202     dummyVarPtr->value.objPtr = NULL;
2203     }
2204    
2205     /*
2206     * If the variable was a namespace variable, decrement its reference count.
2207     */
2208    
2209     if (varPtr->flags & VAR_NAMESPACE_VAR) {
2210     varPtr->flags &= ~VAR_NAMESPACE_VAR;
2211     varPtr->refCount--;
2212     }
2213    
2214     /*
2215     * It's an error to unset an undefined variable.
2216     */
2217    
2218     if (result != TCL_OK) {
2219     if (flags & TCL_LEAVE_ERR_MSG) {
2220     VarErrMsg(interp, part1, part2, "unset",
2221     ((arrayPtr == NULL) ? noSuchVar : noSuchElement));
2222     }
2223     }
2224    
2225     /*
2226     * Finally, if the variable is truly not in use then free up its Var
2227     * structure and remove it from its hash table, if any. The ref count of
2228     * its value object, if any, was decremented above.
2229     */
2230    
2231     CleanupVar(varPtr, arrayPtr);
2232     return result;
2233     }
2234    
2235     /*
2236     *----------------------------------------------------------------------
2237     *
2238     * Tcl_TraceVar --
2239     *
2240     * Arrange for reads and/or writes to a variable to cause a
2241     * procedure to be invoked, which can monitor the operations
2242     * and/or change their actions.
2243     *
2244     * Results:
2245     * A standard Tcl return value.
2246     *
2247     * Side effects:
2248     * A trace is set up on the variable given by varName, such that
2249     * future references to the variable will be intermediated by
2250     * proc. See the manual entry for complete details on the calling
2251     * sequence for proc.
2252     *
2253     *----------------------------------------------------------------------
2254     */
2255    
2256     int
2257     Tcl_TraceVar(interp, varName, flags, proc, clientData)
2258     Tcl_Interp *interp; /* Interpreter in which variable is
2259     * to be traced. */
2260     char *varName; /* Name of variable; may end with "(index)"
2261     * to signify an array reference. */
2262     int flags; /* OR-ed collection of bits, including any
2263     * of TCL_TRACE_READS, TCL_TRACE_WRITES,
2264     * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
2265     * TCL_NAMESPACE_ONLY. */
2266     Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
2267     * invoked upon varName. */
2268     ClientData clientData; /* Arbitrary argument to pass to proc. */
2269     {
2270     return Tcl_TraceVar2(interp, varName, (char *) NULL,
2271     flags, proc, clientData);
2272     }
2273    
2274     /*
2275     *----------------------------------------------------------------------
2276     *
2277     * Tcl_TraceVar2 --
2278     *
2279     * Arrange for reads and/or writes to a variable to cause a
2280     * procedure to be invoked, which can monitor the operations
2281     * and/or change their actions.
2282     *
2283     * Results:
2284     * A standard Tcl return value.
2285     *
2286     * Side effects:
2287     * A trace is set up on the variable given by part1 and part2, such
2288     * that future references to the variable will be intermediated by
2289     * proc. See the manual entry for complete details on the calling
2290     * sequence for proc.
2291     *
2292     *----------------------------------------------------------------------
2293     */
2294    
2295     int
2296     Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
2297     Tcl_Interp *interp; /* Interpreter in which variable is
2298     * to be traced. */
2299     char *part1; /* Name of scalar variable or array. */
2300     char *part2; /* Name of element within array; NULL means
2301     * trace applies to scalar variable or array
2302     * as-a-whole. */
2303     int flags; /* OR-ed collection of bits, including any
2304     * of TCL_TRACE_READS, TCL_TRACE_WRITES,
2305     * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
2306     * and TCL_NAMESPACE_ONLY. */
2307     Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
2308     * invoked upon varName. */
2309     ClientData clientData; /* Arbitrary argument to pass to proc. */
2310     {
2311     Var *varPtr, *arrayPtr;
2312     register VarTrace *tracePtr;
2313    
2314     varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
2315     "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
2316     if (varPtr == NULL) {
2317     return TCL_ERROR;
2318     }
2319    
2320     /*
2321     * Set up trace information.
2322     */
2323    
2324     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
2325     tracePtr->traceProc = proc;
2326     tracePtr->clientData = clientData;
2327     tracePtr->flags =
2328     flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
2329     TCL_TRACE_ARRAY);
2330     tracePtr->nextPtr = varPtr->tracePtr;
2331     varPtr->tracePtr = tracePtr;
2332     return TCL_OK;
2333     }
2334    
2335     /*
2336     *----------------------------------------------------------------------
2337     *
2338     * Tcl_UntraceVar --
2339     *
2340     * Remove a previously-created trace for a variable.
2341     *
2342     * Results:
2343     * None.
2344     *
2345     * Side effects:
2346     * If there exists a trace for the variable given by varName
2347     * with the given flags, proc, and clientData, then that trace
2348     * is removed.
2349     *
2350     *----------------------------------------------------------------------
2351     */
2352    
2353     void
2354     Tcl_UntraceVar(interp, varName, flags, proc, clientData)
2355     Tcl_Interp *interp; /* Interpreter containing variable. */
2356     char *varName; /* Name of variable; may end with "(index)"
2357     * to signify an array reference. */
2358     int flags; /* OR-ed collection of bits describing
2359     * current trace, including any of
2360     * TCL_TRACE_READS, TCL_TRACE_WRITES,
2361     * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
2362     * and TCL_NAMESPACE_ONLY. */
2363     Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
2364     ClientData clientData; /* Arbitrary argument to pass to proc. */
2365     {
2366     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
2367     }
2368    
2369     /*
2370     *----------------------------------------------------------------------
2371     *
2372     * Tcl_UntraceVar2 --
2373     *
2374     * Remove a previously-created trace for a variable.
2375     *
2376     * Results:
2377     * None.
2378     *
2379     * Side effects:
2380     * If there exists a trace for the variable given by part1
2381     * and part2 with the given flags, proc, and clientData, then
2382     * that trace is removed.
2383     *
2384     *----------------------------------------------------------------------
2385     */
2386    
2387     void
2388     Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
2389     Tcl_Interp *interp; /* Interpreter containing variable. */
2390     char *part1; /* Name of variable or array. */
2391     char *part2; /* Name of element within array; NULL means
2392     * trace applies to scalar variable or array
2393     * as-a-whole. */
2394     int flags; /* OR-ed collection of bits describing
2395     * current trace, including any of
2396     * TCL_TRACE_READS, TCL_TRACE_WRITES,
2397     * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
2398     * and TCL_NAMESPACE_ONLY. */
2399     Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
2400     ClientData clientData; /* Arbitrary argument to pass to proc. */
2401     {
2402     register VarTrace *tracePtr;
2403     VarTrace *prevPtr;
2404     Var *varPtr, *arrayPtr;
2405     Interp *iPtr = (Interp *) interp;
2406     ActiveVarTrace *activePtr;
2407    
2408     varPtr = TclLookupVar(interp, part1, part2,
2409     flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
2410     /*msg*/ (char *) NULL,
2411     /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
2412     if (varPtr == NULL) {
2413     return;
2414     }
2415    
2416     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS |
2417     TCL_TRACE_ARRAY);
2418     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
2419     prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
2420     if (tracePtr == NULL) {
2421     return;
2422     }
2423     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
2424     && (tracePtr->clientData == clientData)) {
2425     break;
2426     }
2427     }
2428    
2429     /*
2430     * The code below makes it possible to delete traces while traces
2431     * are active: it makes sure that the deleted trace won't be
2432     * processed by CallTraces.
2433     */
2434    
2435     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
2436     activePtr = activePtr->nextPtr) {
2437     if (activePtr->nextTracePtr == tracePtr) {
2438     activePtr->nextTracePtr = tracePtr->nextPtr;
2439     }
2440     }
2441     if (prevPtr == NULL) {
2442     varPtr->tracePtr = tracePtr->nextPtr;
2443     } else {
2444     prevPtr->nextPtr = tracePtr->nextPtr;
2445     }
2446     ckfree((char *) tracePtr);
2447    
2448     /*
2449     * If this is the last trace on the variable, and the variable is
2450     * unset and unused, then free up the variable.
2451     */
2452    
2453     if (TclIsVarUndefined(varPtr)) {
2454     CleanupVar(varPtr, (Var *) NULL);
2455     }
2456     }
2457    
2458     /*
2459     *----------------------------------------------------------------------
2460     *
2461     * Tcl_VarTraceInfo --
2462     *
2463     * Return the clientData value associated with a trace on a
2464     * variable. This procedure can also be used to step through
2465     * all of the traces on a particular variable that have the
2466     * same trace procedure.
2467     *
2468     * Results:
2469     * The return value is the clientData value associated with
2470     * a trace on the given variable. Information will only be
2471     * returned for a trace with proc as trace procedure. If
2472     * the clientData argument is NULL then the first such trace is
2473     * returned; otherwise, the next relevant one after the one
2474     * given by clientData will be returned. If the variable
2475     * doesn't exist, or if there are no (more) traces for it,
2476     * then NULL is returned.
2477     *
2478     * Side effects:
2479     * None.
2480     *
2481     *----------------------------------------------------------------------
2482     */
2483    
2484     ClientData
2485     Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
2486     Tcl_Interp *interp; /* Interpreter containing variable. */
2487     char *varName; /* Name of variable; may end with "(index)"
2488     * to signify an array reference. */
2489     int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
2490     * TCL_NAMESPACE_ONLY (can be 0). */
2491     Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
2492     ClientData prevClientData; /* If non-NULL, gives last value returned
2493     * by this procedure, so this call will
2494     * return the next trace after that one.
2495     * If NULL, this call will return the
2496     * first trace. */
2497     {
2498     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL,
2499     flags, proc, prevClientData);
2500     }
2501    
2502     /*
2503     *----------------------------------------------------------------------
2504     *
2505     * Tcl_VarTraceInfo2 --
2506     *
2507     * Same as Tcl_VarTraceInfo, except takes name in two pieces
2508     * instead of one.
2509     *
2510     * Results:
2511     * Same as Tcl_VarTraceInfo.
2512     *
2513     * Side effects:
2514     * None.
2515     *
2516     *----------------------------------------------------------------------
2517     */
2518    
2519     ClientData
2520     Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
2521     Tcl_Interp *interp; /* Interpreter containing variable. */
2522     char *part1; /* Name of variable or array. */
2523     char *part2; /* Name of element within array; NULL means
2524     * trace applies to scalar variable or array
2525     * as-a-whole. */
2526     int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
2527     * TCL_NAMESPACE_ONLY. */
2528     Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
2529     ClientData prevClientData; /* If non-NULL, gives last value returned
2530     * by this procedure, so this call will
2531     * return the next trace after that one.
2532     * If NULL, this call will return the
2533     * first trace. */
2534     {
2535     register VarTrace *tracePtr;
2536     Var *varPtr, *arrayPtr;
2537    
2538     varPtr = TclLookupVar(interp, part1, part2,
2539     flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY),
2540     /*msg*/ (char *) NULL,
2541     /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
2542     if (varPtr == NULL) {
2543     return NULL;
2544     }
2545    
2546     /*
2547     * Find the relevant trace, if any, and return its clientData.
2548     */
2549    
2550     tracePtr = varPtr->tracePtr;
2551     if (prevClientData != NULL) {
2552     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
2553     if ((tracePtr->clientData == prevClientData)
2554     && (tracePtr->traceProc == proc)) {
2555     tracePtr = tracePtr->nextPtr;
2556     break;
2557     }
2558     }
2559     }
2560     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
2561     if (tracePtr->traceProc == proc) {
2562     return tracePtr->clientData;
2563     }
2564     }
2565     return NULL;
2566     }
2567    
2568     /*
2569     *----------------------------------------------------------------------
2570     *
2571     * Tcl_UnsetObjCmd --
2572     *
2573     * This object-based procedure is invoked to process the "unset" Tcl
2574     * command. See the user documentation for details on what it does.
2575     *
2576     * Results:
2577     * A standard Tcl object result value.
2578     *
2579     * Side effects:
2580     * See the user documentation.
2581     *
2582     *----------------------------------------------------------------------
2583     */
2584    
2585     /* ARGSUSED */
2586     int
2587     Tcl_UnsetObjCmd(dummy, interp, objc, objv)
2588     ClientData dummy; /* Not used. */
2589     Tcl_Interp *interp; /* Current interpreter. */
2590     int objc; /* Number of arguments. */
2591     Tcl_Obj *CONST objv[]; /* Argument objects. */
2592     {
2593     register int i;
2594     register char *name;
2595    
2596     if (objc < 2) {
2597     Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
2598     return TCL_ERROR;
2599     }
2600    
2601     for (i = 1; i < objc; i++) {
2602     name = TclGetString(objv[i]);
2603     if (Tcl_UnsetVar2(interp, name, (char *) NULL,
2604     TCL_LEAVE_ERR_MSG) != TCL_OK) {
2605     return TCL_ERROR;
2606     }
2607     }
2608     return TCL_OK;
2609     }
2610    
2611     /*
2612     *----------------------------------------------------------------------
2613     *
2614     * Tcl_AppendObjCmd --
2615     *
2616     * This object-based procedure is invoked to process the "append"
2617     * Tcl command. See the user documentation for details on what it does.
2618     *
2619     * Results:
2620     * A standard Tcl object result value.
2621     *
2622     * Side effects:
2623     * A variable's value may be changed.
2624     *
2625     *----------------------------------------------------------------------
2626     */
2627    
2628     /* ARGSUSED */
2629     int
2630     Tcl_AppendObjCmd(dummy, interp, objc, objv)
2631     ClientData dummy; /* Not used. */
2632     Tcl_Interp *interp; /* Current interpreter. */
2633     int objc; /* Number of arguments. */
2634     Tcl_Obj *CONST objv[]; /* Argument objects. */
2635     {
2636     register Tcl_Obj *varValuePtr = NULL;
2637     /* Initialized to avoid compiler
2638     * warning. */
2639     int i;
2640    
2641     if (objc < 2) {
2642     Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
2643     return TCL_ERROR;
2644     }
2645     if (objc == 2) {
2646     varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
2647     if (varValuePtr == NULL) {
2648     return TCL_ERROR;
2649     }
2650     } else {
2651     for (i = 2; i < objc; i++) {
2652     varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL,
2653     objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
2654     if (varValuePtr == NULL) {
2655     return TCL_ERROR;
2656     }
2657     }
2658     }
2659     Tcl_SetObjResult(interp, varValuePtr);
2660     return TCL_OK;
2661     }
2662    
2663     /*
2664     *----------------------------------------------------------------------
2665     *
2666     * Tcl_LappendObjCmd --
2667     *
2668     * This object-based procedure is invoked to process the "lappend"
2669     * Tcl command. See the user documentation for details on what it does.
2670     *
2671     * Results:
2672     * A standard Tcl object result value.
2673     *
2674     * Side effects:
2675     * A variable's value may be changed.
2676     *
2677     *----------------------------------------------------------------------
2678     */
2679    
2680     /* ARGSUSED */
2681     int
2682     Tcl_LappendObjCmd(dummy, interp, objc, objv)
2683     ClientData dummy; /* Not used. */
2684     Tcl_Interp *interp; /* Current interpreter. */
2685     int objc; /* Number of arguments. */
2686     Tcl_Obj *CONST objv[]; /* Argument objects. */
2687     {
2688     Tcl_Obj *varValuePtr, *newValuePtr;
2689     register List *listRepPtr;
2690     register Tcl_Obj **elemPtrs;
2691     int numElems, numRequired, createdNewObj, createVar, i, j;
2692    
2693     if (objc < 2) {
2694     Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
2695     return TCL_ERROR;
2696     }
2697     if (objc == 2) {
2698     newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL,
2699     (TCL_LEAVE_ERR_MSG));
2700     if (newValuePtr == NULL) {
2701     /*
2702     * The variable doesn't exist yet. Just create it with an empty
2703     * initial value.
2704     */
2705    
2706     Tcl_Obj *nullObjPtr = Tcl_NewObj();
2707     newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL,
2708     nullObjPtr, TCL_LEAVE_ERR_MSG);
2709     if (newValuePtr == NULL) {
2710     Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */
2711     return TCL_ERROR;
2712     }
2713     }
2714     } else {
2715     /*
2716     * We have arguments to append. We used to call Tcl_SetVar2 to
2717     * append each argument one at a time to ensure that traces were run
2718     * for each append step. We now append the arguments all at once
2719     * because it's faster. Note that a read trace and a write trace for
2720     * the variable will now each only be called once. Also, if the
2721     * variable's old value is unshared we modify it directly, otherwise
2722     * we create a new copy to modify: this is "copy on write".
2723     */
2724    
2725     createdNewObj = 0;
2726     createVar = 1;
2727     varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);
2728     if (varValuePtr == NULL) {
2729     /*
2730     * We couldn't read the old value: either the var doesn't yet
2731     * exist or it's an array element. If it's new, we will try to
2732     * create it with Tcl_ObjSetVar2 below.
2733     */
2734    
2735     char *p, *varName;
2736     int nameBytes, i;
2737    
2738     varName = Tcl_GetStringFromObj(objv[1], &nameBytes);
2739     for (i = 0, p = varName; i < nameBytes; i++, p++) {
2740     if (*p == '(') {
2741     p = (varName + nameBytes-1);
2742     if (*p == ')') { /* last char is ')' => array ref */
2743     createVar = 0;
2744     }
2745     break;
2746     }
2747     }
2748     varValuePtr = Tcl_NewObj();
2749     createdNewObj = 1;
2750     } else if (Tcl_IsShared(varValuePtr)) {
2751     varValuePtr = Tcl_DuplicateObj(varValuePtr);
2752     createdNewObj = 1;
2753     }
2754    
2755     /*
2756     * Convert the variable's old value to a list object if necessary.
2757     */
2758    
2759     if (varValuePtr->typePtr != &tclListType) {
2760     int result = tclListType.setFromAnyProc(interp, varValuePtr);
2761     if (result != TCL_OK) {
2762     if (createdNewObj) {
2763     Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */
2764     }
2765     return result;
2766     }
2767     }
2768     listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr;
2769     elemPtrs = listRepPtr->elements;
2770     numElems = listRepPtr->elemCount;
2771    
2772     /*
2773     * If there is no room in the current array of element pointers,
2774     * allocate a new, larger array and copy the pointers to it.
2775     */
2776    
2777     numRequired = numElems + (objc-2);
2778     if (numRequired > listRepPtr->maxElemCount) {
2779     int newMax = (2 * numRequired);
2780     Tcl_Obj **newElemPtrs = (Tcl_Obj **)
2781     ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
2782    
2783     memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs,
2784     (size_t) (numElems * sizeof(Tcl_Obj *)));
2785     listRepPtr->maxElemCount = newMax;
2786     listRepPtr->elements = newElemPtrs;
2787     ckfree((char *) elemPtrs);
2788     elemPtrs = newElemPtrs;
2789     }
2790    
2791     /*
2792     * Insert the new elements at the end of the list.
2793     */
2794    
2795     for (i = 2, j = numElems; i < objc; i++, j++) {
2796     elemPtrs[j] = objv[i];
2797     Tcl_IncrRefCount(objv[i]);
2798     }
2799     listRepPtr->elemCount = numRequired;
2800    
2801     /*
2802     * Invalidate and free any old string representation since it no
2803     * longer reflects the list's internal representation.
2804     */
2805    
2806     Tcl_InvalidateStringRep(varValuePtr);
2807    
2808     /*
2809     * Now store the list object back into the variable. If there is an
2810     * error setting the new value, decrement its ref count if it
2811     * was new and we didn't create the variable.
2812     */
2813    
2814     newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
2815     TCL_LEAVE_ERR_MSG);
2816     if (newValuePtr == NULL) {
2817     if (createdNewObj && !createVar) {
2818     Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
2819     }
2820     return TCL_ERROR;
2821     }
2822     }
2823    
2824     /*
2825     * Set the interpreter's object result to refer to the variable's value
2826     * object.
2827     */
2828    
2829     Tcl_SetObjResult(interp, newValuePtr);
2830     return TCL_OK;
2831     }
2832    
2833     /*
2834     *----------------------------------------------------------------------
2835     *
2836     * Tcl_ArrayObjCmd --
2837     *
2838     * This object-based procedure is invoked to process the "array" Tcl
2839     * command. See the user documentation for details on what it does.
2840     *
2841     * Results:
2842     * A standard Tcl result object.
2843     *
2844     * Side effects:
2845     * See the user documentation.
2846     *
2847     *----------------------------------------------------------------------
2848     */
2849    
2850     /* ARGSUSED */
2851     int
2852     Tcl_ArrayObjCmd(dummy, interp, objc, objv)
2853     ClientData dummy; /* Not used. */
2854     Tcl_Interp *interp; /* Current interpreter. */
2855     int objc; /* Number of arguments. */
2856     Tcl_Obj *CONST objv[]; /* Argument objects. */
2857     {
2858     /*
2859     * The list of constants below should match the arrayOptions string array
2860     * below.
2861     */
2862    
2863     enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET,
2864     ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE,
2865     ARRAY_STARTSEARCH, ARRAY_UNSET};
2866     static char *arrayOptions[] = {
2867     "anymore", "donesearch", "exists", "get", "names", "nextelement",
2868     "set", "size", "startsearch", "unset", (char *) NULL
2869     };
2870    
2871     Interp *iPtr = (Interp *) interp;
2872     Var *varPtr, *arrayPtr;
2873     Tcl_HashEntry *hPtr;
2874     Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
2875     int notArray;
2876     char *varName, *msg;
2877     int index, result;
2878    
2879    
2880     if (objc < 3) {
2881     Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
2882     return TCL_ERROR;
2883     }
2884    
2885     if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
2886     0, &index) != TCL_OK) {
2887     return TCL_ERROR;
2888     }
2889    
2890     /*
2891     * Locate the array variable (and it better be an array).
2892     */
2893    
2894     varName = TclGetString(objv[2]);
2895     varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
2896     /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
2897    
2898     notArray = 0;
2899     if ((varPtr == NULL) || !TclIsVarArray(varPtr)
2900     || TclIsVarUndefined(varPtr)) {
2901     notArray = 1;
2902     }
2903    
2904     /*
2905     * Special array trace used to keep the env array in sync for
2906     * array names, array get, etc.
2907     */
2908    
2909     if (varPtr != NULL && varPtr->tracePtr != NULL) {
2910     msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL,
2911     (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
2912     TCL_TRACE_ARRAY));
2913     if (msg != NULL) {
2914     VarErrMsg(interp, varName, NULL, "trace array", msg);
2915     return TCL_ERROR;
2916     }
2917     }
2918    
2919     switch (index) {
2920     case ARRAY_ANYMORE: {
2921     ArraySearch *searchPtr;
2922     char *searchId;
2923    
2924     if (objc != 4) {
2925     Tcl_WrongNumArgs(interp, 2, objv,
2926     "arrayName searchId");
2927     return TCL_ERROR;
2928     }
2929     if (notArray) {
2930     goto error;
2931     }
2932     searchId = Tcl_GetString(objv[3]);
2933     searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
2934     if (searchPtr == NULL) {
2935     return TCL_ERROR;
2936     }
2937     while (1) {
2938     Var *varPtr2;
2939    
2940     if (searchPtr->nextEntry != NULL) {
2941     varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
2942     if (!TclIsVarUndefined(varPtr2)) {
2943     break;
2944     }
2945     }
2946     searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
2947     if (searchPtr->nextEntry == NULL) {
2948     Tcl_SetIntObj(resultPtr, 0);
2949     return TCL_OK;
2950     }
2951     }
2952     Tcl_SetIntObj(resultPtr, 1);
2953     break;
2954     }
2955     case ARRAY_DONESEARCH: {
2956     ArraySearch *searchPtr, *prevPtr;
2957     char *searchId;
2958    
2959     if (objc != 4) {
2960     Tcl_WrongNumArgs(interp, 2, objv,
2961     "arrayName searchId");
2962     return TCL_ERROR;
2963     }
2964     if (notArray) {
2965     goto error;
2966     }
2967     searchId = Tcl_GetString(objv[3]);
2968     searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
2969     if (searchPtr == NULL) {
2970     return TCL_ERROR;
2971     }
2972     if (varPtr->searchPtr == searchPtr) {
2973     varPtr->searchPtr = searchPtr->nextPtr;
2974     } else {
2975     for (prevPtr = varPtr->searchPtr; ;
2976     prevPtr = prevPtr->nextPtr) {
2977     if (prevPtr->nextPtr == searchPtr) {
2978     prevPtr->nextPtr = searchPtr->nextPtr;
2979     break;
2980     }
2981     }
2982     }
2983     ckfree((char *) searchPtr);
2984     break;
2985     }
2986     case ARRAY_EXISTS: {
2987     if (objc != 3) {
2988     Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
2989     return TCL_ERROR;
2990     }
2991     Tcl_SetIntObj(resultPtr, !notArray);
2992     break;
2993     }
2994     case ARRAY_GET: {
2995     Tcl_HashSearch search;
2996     Var *varPtr2;
2997     char *pattern = NULL;
2998     char *name;
2999     Tcl_Obj *namePtr, *valuePtr;
3000    
3001     if ((objc != 3) && (objc != 4)) {
3002     Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
3003     return TCL_ERROR;
3004     }
3005     if (notArray) {
3006     return TCL_OK;
3007     }
3008     if (objc == 4) {
3009     pattern = TclGetString(objv[3]);
3010     }
3011     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
3012     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3013     varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
3014     if (TclIsVarUndefined(varPtr2)) {
3015     continue;
3016     }
3017     name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
3018     if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
3019     continue; /* element name doesn't match pattern */
3020     }
3021    
3022     namePtr = Tcl_NewStringObj(name, -1);
3023     result = Tcl_ListObjAppendElement(interp, resultPtr,
3024     namePtr);
3025     if (result != TCL_OK) {
3026     Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
3027     return result;
3028     }
3029    
3030     valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr,
3031     TCL_LEAVE_ERR_MSG);
3032     if (valuePtr == NULL) {
3033     Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
3034     return result;
3035     }
3036     result = Tcl_ListObjAppendElement(interp, resultPtr,
3037     valuePtr);
3038     if (result != TCL_OK) {
3039     Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
3040     return result;
3041     }
3042     }
3043     break;
3044     }
3045     case ARRAY_NAMES: {
3046     Tcl_HashSearch search;
3047     Var *varPtr2;
3048     char *pattern = NULL;
3049     char *name;
3050     Tcl_Obj *namePtr;
3051    
3052     if ((objc != 3) && (objc != 4)) {
3053     Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
3054     return TCL_ERROR;
3055     }
3056     if (notArray) {
3057     return TCL_OK;
3058     }
3059     if (objc == 4) {
3060     pattern = Tcl_GetString(objv[3]);
3061     }
3062     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
3063     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3064     varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
3065     if (TclIsVarUndefined(varPtr2)) {
3066     continue;
3067     }
3068     name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
3069     if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
3070     continue; /* element name doesn't match pattern */
3071     }
3072    
3073     namePtr = Tcl_NewStringObj(name, -1);
3074     result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
3075     if (result != TCL_OK) {
3076     Tcl_DecrRefCount(namePtr); /* free unneeded name obj */
3077     return result;
3078     }
3079     }
3080     break;
3081     }
3082     case ARRAY_NEXTELEMENT: {
3083     ArraySearch *searchPtr;
3084     char *searchId;
3085     Tcl_HashEntry *hPtr;
3086    
3087     if (objc != 4) {
3088     Tcl_WrongNumArgs(interp, 2, objv,
3089     "arrayName searchId");
3090     return TCL_ERROR;
3091     }
3092     if (notArray) {
3093     goto error;
3094     }
3095     searchId = Tcl_GetString(objv[3]);
3096     searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
3097     if (searchPtr == NULL) {
3098     return TCL_ERROR;
3099     }
3100     while (1) {
3101     Var *varPtr2;
3102    
3103     hPtr = searchPtr->nextEntry;
3104     if (hPtr == NULL) {
3105     hPtr = Tcl_NextHashEntry(&searchPtr->search);
3106     if (hPtr == NULL) {
3107     return TCL_OK;
3108     }
3109     } else {
3110     searchPtr->nextEntry = NULL;
3111     }
3112     varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
3113     if (!TclIsVarUndefined(varPtr2)) {
3114     break;
3115     }
3116     }
3117     Tcl_SetStringObj(resultPtr,
3118     Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
3119     break;
3120     }
3121     case ARRAY_SET: {
3122     if (objc != 4) {
3123     Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
3124     return TCL_ERROR;
3125     }
3126     return(TclArraySet(interp, objv[2], objv[3]));
3127     }
3128     case ARRAY_SIZE: {
3129     Tcl_HashSearch search;
3130     Var *varPtr2;
3131     int size;
3132    
3133     if (objc != 3) {
3134     Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
3135     return TCL_ERROR;
3136     }
3137     size = 0;
3138     if (!notArray) {
3139     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
3140     &search);
3141     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3142     varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
3143     if (TclIsVarUndefined(varPtr2)) {
3144     continue;
3145     }
3146     size++;
3147     }
3148     }
3149     Tcl_SetIntObj(resultPtr, size);
3150     break;
3151     }
3152     case ARRAY_STARTSEARCH: {
3153     ArraySearch *searchPtr;
3154    
3155     if (objc != 3) {
3156     Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
3157     return TCL_ERROR;
3158     }
3159     if (notArray) {
3160     goto error;
3161     }
3162     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
3163     if (varPtr->searchPtr == NULL) {
3164     searchPtr->id = 1;
3165     Tcl_AppendStringsToObj(resultPtr, "s-1-", varName,
3166     (char *) NULL);
3167     } else {
3168     char string[TCL_INTEGER_SPACE];
3169    
3170     searchPtr->id = varPtr->searchPtr->id + 1;
3171     TclFormatInt(string, searchPtr->id);
3172     Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName,
3173     (char *) NULL);
3174     }
3175     searchPtr->varPtr = varPtr;
3176     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
3177     &searchPtr->search);
3178     searchPtr->nextPtr = varPtr->searchPtr;
3179     varPtr->searchPtr = searchPtr;
3180     break;
3181     }
3182     case ARRAY_UNSET: {
3183     Tcl_HashSearch search;
3184     Var *varPtr2;
3185     char *pattern = NULL;
3186     char *name;
3187    
3188     if ((objc != 3) && (objc != 4)) {
3189     Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
3190     return TCL_ERROR;
3191     }
3192     if (notArray) {
3193     return TCL_OK;
3194     }
3195     if (objc == 3) {
3196     /*
3197     * When no pattern is given, just unset the whole array
3198     */
3199     if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0)
3200     != TCL_OK) {
3201     return TCL_ERROR;
3202     }
3203     } else {
3204     pattern = Tcl_GetString(objv[3]);
3205     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
3206     &search);
3207     hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3208     varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
3209     if (TclIsVarUndefined(varPtr2)) {
3210     continue;
3211     }
3212     name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
3213     if (Tcl_StringMatch(name, pattern) &&
3214     (Tcl_UnsetVar2(interp, varName, name, 0)
3215     != TCL_OK)) {
3216     return TCL_ERROR;
3217     }
3218     }
3219     }
3220     break;
3221     }
3222     }
3223     return TCL_OK;
3224    
3225     error:
3226     Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array",
3227     (char *) NULL);
3228     return TCL_ERROR;
3229     }
3230    
3231     /*
3232     *----------------------------------------------------------------------
3233     *
3234     * TclArraySet --
3235     *
3236     * Set the elements of an array. If there are no elements to
3237     * set, create an empty array. This routine is used by the
3238     * Tcl_ArrayObjCmd and by the TclSetupEnv routine.
3239     *
3240     * Results:
3241     * A standard Tcl result object.
3242     *
3243     * Side effects:
3244     * A variable will be created if one does not already exist.
3245     *
3246     *----------------------------------------------------------------------
3247     */
3248    
3249     int
3250     TclArraySet(interp, arrayNameObj, arrayElemObj)
3251     Tcl_Interp *interp; /* Current interpreter. */
3252     Tcl_Obj *arrayNameObj; /* The array name. */
3253     Tcl_Obj *arrayElemObj; /* The array elements list. If this is
3254     * NULL, create an empty array. */
3255     {
3256     Var *varPtr, *arrayPtr;
3257     Tcl_Obj **elemPtrs;
3258     int result, elemLen, i;
3259     char *varName, *p;
3260    
3261     varName = TclGetString(arrayNameObj);
3262     for (p = varName; *p ; p++) {
3263     if (*p == '(') {
3264     do {
3265     p++;
3266     } while (*p != '\0');
3267     p--;
3268     if (*p == ')') {
3269     VarErrMsg(interp, varName, NULL, "set", needArray);
3270     return TCL_ERROR;
3271     }
3272     break;
3273     }
3274     }
3275    
3276     varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
3277     /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
3278    
3279     if (arrayElemObj != NULL) {
3280     result = Tcl_ListObjGetElements(interp, arrayElemObj,
3281     &elemLen, &elemPtrs);
3282     if (result != TCL_OK) {
3283     return result;
3284     }
3285     if (elemLen & 1) {
3286     Tcl_ResetResult(interp);
3287     Tcl_AppendToObj(Tcl_GetObjResult(interp),
3288     "list must have an even number of elements", -1);
3289     return TCL_ERROR;
3290     }
3291     if (elemLen > 0) {
3292     for (i = 0; i < elemLen; i += 2) {
3293     if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i],
3294     elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) {
3295     result = TCL_ERROR;
3296     break;
3297     }
3298     }
3299     return result;
3300     }
3301     }
3302    
3303     /*
3304     * The list is empty make sure we have an array, or create
3305     * one if necessary.
3306     */
3307    
3308     if (varPtr != NULL) {
3309     if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) {
3310     /*
3311     * Already an array, done.
3312     */
3313    
3314     return TCL_OK;
3315     }
3316     if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
3317     /*
3318     * Either an array element, or a scalar: lose!
3319     */
3320    
3321     VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
3322     return TCL_ERROR;
3323     }
3324     } else {
3325     /*
3326     * Create variable for new array.
3327     */
3328    
3329     varPtr = TclLookupVar(interp, varName, (char *) NULL,
3330     TCL_LEAVE_ERR_MSG, "set",
3331     /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
3332    
3333     /*
3334     * Still couldn't do it - this can occur if a non-existent
3335     * namespace was specified
3336     */
3337     if (varPtr == NULL) {
3338     return TCL_ERROR;
3339     }
3340     }
3341     TclSetVarArray(varPtr);
3342     TclClearVarUndefined(varPtr);
3343     varPtr->value.tablePtr =
3344     (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
3345     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
3346     return TCL_OK;
3347     }
3348    
3349     /*
3350     *----------------------------------------------------------------------
3351     *
3352     * MakeUpvar --
3353     *
3354     * This procedure does all of the work of the "global" and "upvar"
3355     * commands.
3356     *
3357     * Results:
3358     * A standard Tcl completion code. If an error occurs then an
3359     * error message is left in iPtr->result.
3360     *
3361     * Side effects:
3362     * The variable given by myName is linked to the variable in framePtr
3363     * given by otherP1 and otherP2, so that references to myName are
3364     * redirected to the other variable like a symbolic link.
3365     *
3366     *----------------------------------------------------------------------
3367     */
3368    
3369     static int
3370     MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags)
3371     Interp *iPtr; /* Interpreter containing variables. Used
3372     * for error messages, too. */
3373     CallFrame *framePtr; /* Call frame containing "other" variable.
3374     * NULL means use global :: context. */
3375     char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */
3376     int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
3377     * indicates scope of "other" variable. */
3378     char *myName; /* Name of variable which will refer to
3379     * otherP1/otherP2. Must be a scalar. */
3380     int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
3381     * indicates scope of myName. */
3382     {
3383     Tcl_HashEntry *hPtr;
3384     Var *otherPtr, *varPtr, *arrayPtr;
3385     CallFrame *varFramePtr;
3386     CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */
3387     Tcl_HashTable *tablePtr;
3388     Namespace *nsPtr, *altNsPtr, *dummyNsPtr;
3389     char *tail;
3390     int new;
3391    
3392     /*
3393     * Find "other" in "framePtr". If not looking up other in just the
3394     * current namespace, temporarily replace the current var frame
3395     * pointer in the interpreter in order to use TclLookupVar.
3396     */
3397    
3398     if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
3399     savedFramePtr = iPtr->varFramePtr;
3400     iPtr->varFramePtr = framePtr;
3401     }
3402     otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
3403     (otherFlags | TCL_LEAVE_ERR_MSG), "access",
3404     /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
3405     if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
3406     iPtr->varFramePtr = savedFramePtr;
3407     }
3408     if (otherPtr == NULL) {
3409     return TCL_ERROR;
3410     }
3411    
3412     /*
3413     * Now create a hashtable entry for "myName". Create it as either a
3414     * namespace variable or as a local variable in a procedure call
3415     * frame. Interpret myName as a namespace variable if:
3416     * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
3417     * 2) there is no active frame (we're at the global :: scope),
3418     * 3) the active frame was pushed to define the namespace context
3419     * for a "namespace eval" or "namespace inscope" command,
3420     * 4) the name has namespace qualifiers ("::"s).
3421     * If creating myName in the active procedure, look first in the
3422     * frame's array of compiler-allocated local variables, then in its
3423     * hashtable for runtime-created local variables. Create that
3424     * procedure's local variable hashtable if necessary.
3425     */
3426    
3427     varFramePtr = iPtr->varFramePtr;
3428     if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
3429     || (varFramePtr == NULL)
3430     || !varFramePtr->isProcCallFrame
3431     || (strstr(myName, "::") != NULL)) {
3432     TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName,
3433     (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail);
3434    
3435     if (nsPtr == NULL) {
3436     nsPtr = altNsPtr;
3437     }
3438     if (nsPtr == NULL) {
3439     Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
3440     myName, "\": unknown namespace", (char *) NULL);
3441     return TCL_ERROR;
3442     }
3443    
3444     /*
3445     * Check that we are not trying to create a namespace var linked to
3446     * a local variable in a procedure. If we allowed this, the local
3447     * variable in the shorter-lived procedure frame could go away
3448     * leaving the namespace var's reference invalid.
3449     */
3450    
3451     if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) {
3452     Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
3453     myName, "\": upvar won't create namespace variable that refers to procedure variable",
3454     (char *) NULL);
3455     return TCL_ERROR;
3456     }
3457    
3458     hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new);
3459     if (new) {
3460     varPtr = NewVar();
3461     Tcl_SetHashValue(hPtr, varPtr);
3462     varPtr->hPtr = hPtr;
3463     varPtr->nsPtr = nsPtr;
3464     } else {
3465     varPtr = (Var *) Tcl_GetHashValue(hPtr);
3466     }
3467     } else { /* look in the call frame */
3468     Proc *procPtr = varFramePtr->procPtr;
3469     int localCt = procPtr->numCompiledLocals;
3470     CompiledLocal *localPtr = procPtr->firstLocalPtr;
3471     Var *localVarPtr = varFramePtr->compiledLocals;
3472     int nameLen = strlen(myName);
3473     int i;
3474    
3475     varPtr = NULL;
3476     for (i = 0; i < localCt; i++) {
3477     if (!TclIsVarTemporary(localPtr)) {
3478     char *localName = localVarPtr->name;
3479     if ((myName[0] == localName[0])
3480     && (nameLen == localPtr->nameLength)
3481     && (strcmp(myName, localName) == 0)) {
3482     varPtr = localVarPtr;
3483     new = 0;
3484     break;
3485     }
3486     }
3487     localVarPtr++;
3488     localPtr = localPtr->nextPtr;
3489     }
3490     if (varPtr == NULL) { /* look in frame's local var hashtable */
3491     tablePtr = varFramePtr->varTablePtr;
3492     if (tablePtr == NULL) {
3493     tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
3494     Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
3495     varFramePtr->varTablePtr = tablePtr;
3496     }
3497     hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new);
3498     if (new) {
3499     varPtr = NewVar();
3500     Tcl_SetHashValue(hPtr, varPtr);
3501     varPtr->hPtr = hPtr;
3502     varPtr->nsPtr = varFramePtr->nsPtr;
3503     } else {
3504     varPtr = (Var *) Tcl_GetHashValue(hPtr);
3505     }
3506     }
3507     }
3508    
3509     if (!new) {
3510     /*
3511     * The variable already exists. Make sure this variable "varPtr"
3512     * isn't the same as "otherPtr" (avoid circular links). Also, if
3513     * it's not an upvar then it's an error. If it is an upvar, then
3514     * just disconnect it from the thing it currently refers to.
3515     */
3516    
3517     if (varPtr == otherPtr) {
3518     Tcl_SetResult((Tcl_Interp *) iPtr,
3519     "can't upvar from variable to itself", TCL_STATIC);
3520     return TCL_ERROR;
3521     }
3522     if (TclIsVarLink(varPtr)) {
3523     Var *linkPtr = varPtr->value.linkPtr;
3524     if (linkPtr == otherPtr) {
3525     return TCL_OK;
3526     }
3527     linkPtr->refCount--;
3528     if (TclIsVarUndefined(linkPtr)) {
3529     CleanupVar(linkPtr, (Var *) NULL);
3530     }
3531     } else if (!TclIsVarUndefined(varPtr)) {
3532     Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
3533     "\" already exists", (char *) NULL);
3534     return TCL_ERROR;
3535     } else if (varPtr->tracePtr != NULL) {
3536     Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
3537     "\" has traces: can't use for upvar", (char *) NULL);
3538     return TCL_ERROR;
3539     }
3540     }
3541     TclSetVarLink(varPtr);
3542     TclClearVarUndefined(varPtr);
3543     varPtr->value.linkPtr = otherPtr;
3544     otherPtr->refCount++;
3545     return TCL_OK;
3546     }
3547    
3548     /*
3549     *----------------------------------------------------------------------
3550     *
3551     * Tcl_UpVar --
3552     *
3553     * This procedure links one variable to another, just like
3554     * the "upvar" command.
3555     *
3556     * Results:
3557     * A standard Tcl completion code. If an error occurs then
3558     * an error message is left in the interp's result.
3559     *
3560     * Side effects:
3561     * The variable in frameName whose name is given by varName becomes
3562     * accessible under the name localName, so that references to
3563     * localName are redirected to the other variable like a symbolic
3564     * link.
3565     *
3566     *----------------------------------------------------------------------
3567     */
3568    
3569     int
3570     Tcl_UpVar(interp, frameName, varName, localName, flags)
3571     Tcl_Interp *interp; /* Command interpreter in which varName is
3572     * to be looked up. */
3573     char *frameName; /* Name of the frame containing the source
3574     * variable, such as "1" or "#0". */
3575     char *varName; /* Name of a variable in interp to link to.
3576     * May be either a scalar name or an
3577     * element in an array. */
3578     char *localName; /* Name of link variable. */
3579     int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
3580     * indicates scope of localName. */
3581     {
3582     int result;
3583     CallFrame *framePtr;
3584     register char *p;
3585    
3586     result = TclGetFrame(interp, frameName, &framePtr);
3587     if (result == -1) {
3588     return TCL_ERROR;
3589     }
3590    
3591     /*
3592     * Figure out whether varName is an array reference, then call
3593     * MakeUpvar to do all the real work.
3594     */
3595    
3596     for (p = varName; *p != '\0'; p++) {
3597     if (*p == '(') {
3598     char *openParen = p;
3599     do {
3600     p++;
3601     } while (*p != '\0');
3602     p--;
3603     if (*p != ')') {
3604     goto scalar;
3605     }
3606     *openParen = '\0';
3607     *p = '\0';
3608     result = MakeUpvar((Interp *) interp, framePtr, varName,
3609     openParen+1, 0, localName, flags);
3610     *openParen = '(';
3611     *p = ')';
3612     return result;
3613     }
3614     }
3615    
3616     scalar:
3617     return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL,
3618     0, localName, flags);
3619     }
3620    
3621     /*
3622     *----------------------------------------------------------------------
3623     *
3624     * Tcl_UpVar2 --
3625     *
3626     * This procedure links one variable to another, just like
3627     * the "upvar" command.
3628     *
3629     * Results:
3630     * A standard Tcl completion code. If an error occurs then
3631     * an error message is left in the interp's result.
3632     *
3633     * Side effects:
3634     * The variable in frameName whose name is given by part1 and
3635     * part2 becomes accessible under the name localName, so that
3636     * references to localName are redirected to the other variable
3637     * like a symbolic link.
3638     *
3639     *----------------------------------------------------------------------
3640     */
3641    
3642     int
3643     Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
3644     Tcl_Interp *interp; /* Interpreter containing variables. Used
3645     * for error messages too. */
3646     char *frameName; /* Name of the frame containing the source
3647     * variable, such as "1" or "#0". */
3648     char *part1, *part2; /* Two parts of source variable name to
3649     * link to. */
3650     char *localName; /* Name of link variable. */
3651     int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
3652     * indicates scope of localName. */
3653     {
3654     int result;
3655     CallFrame *framePtr;
3656    
3657     result = TclGetFrame(interp, frameName, &framePtr);
3658     if (result == -1) {
3659     return TCL_ERROR;
3660     }
3661     return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0,
3662     localName, flags);
3663     }
3664    
3665     /*
3666     *----------------------------------------------------------------------
3667     *
3668     * Tcl_GetVariableFullName --
3669     *
3670     * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this
3671     * procedure appends to an object the namespace variable's full
3672     * name, qualified by a sequence of parent namespace names.
3673     *
3674     * Results:
3675     * None.
3676     *
3677     * Side effects:
3678     * The variable's fully-qualified name is appended to the string
3679     * representation of objPtr.
3680     *
3681     *----------------------------------------------------------------------
3682     */
3683    
3684     void
3685     Tcl_GetVariableFullName(interp, variable, objPtr)
3686     Tcl_Interp *interp; /* Interpreter containing the variable. */
3687     Tcl_Var variable; /* Token for the variable returned by a
3688     * previous call to Tcl_FindNamespaceVar. */
3689     Tcl_Obj *objPtr; /* Points to the object onto which the
3690     * variable's full name is appended. */
3691     {
3692     Interp *iPtr = (Interp *) interp;
3693     register Var *varPtr = (Var *) variable;
3694     char *name;
3695    
3696     /*
3697     * Add the full name of the containing namespace (if any), followed by
3698     * the "::" separator, then the variable name.
3699     */
3700    
3701     if (varPtr != NULL) {
3702     if (!TclIsVarArrayElement(varPtr)) {
3703     if (varPtr->nsPtr != NULL) {
3704     Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1);
3705     if (varPtr->nsPtr != iPtr->globalNsPtr) {
3706     Tcl_AppendToObj(objPtr, "::", 2);
3707     }
3708     }
3709     if (varPtr->name != NULL) {
3710     Tcl_AppendToObj(objPtr, varPtr->name, -1);
3711     } else if (varPtr->hPtr != NULL) {
3712     name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr);
3713     Tcl_AppendToObj(objPtr, name, -1);
3714     }
3715     }
3716     }
3717     }
3718    
3719     /*
3720     *----------------------------------------------------------------------
3721     *
3722     * Tcl_GlobalObjCmd --
3723     *
3724     * This object-based procedure is invoked to process the "global" Tcl
3725     * command. See the user documentation for details on what it does.
3726     *
3727     * Results:
3728     * A standard Tcl object result value.
3729     *
3730     * Side effects:
3731     * See the user documentation.
3732     *
3733     *----------------------------------------------------------------------
3734     */
3735    
3736     int
3737     Tcl_GlobalObjCmd(dummy, interp, objc, objv)
3738     ClientData dummy; /* Not used. */
3739     Tcl_Interp *interp; /* Current interpreter. */
3740     int objc; /* Number of arguments. */
3741     Tcl_Obj *CONST objv[]; /* Argument objects. */
3742     {
3743     Interp *iPtr = (Interp *) interp;
3744     register Tcl_Obj *objPtr;
3745     char *varName;
3746     register char *tail;
3747     int result, i;
3748    
3749     if (objc < 2) {
3750     Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?");
3751     return TCL_ERROR;
3752     }
3753    
3754     /*
3755     * If we are not executing inside a Tcl procedure, just return.
3756     */
3757    
3758     if ((iPtr->varFramePtr == NULL)
3759     || !iPtr->varFramePtr->isProcCallFrame) {
3760     return TCL_OK;
3761     }
3762    
3763     for (i = 1; i < objc; i++) {
3764     /*
3765     * Make a local variable linked to its counterpart in the global ::
3766     * namespace.
3767     */
3768    
3769     objPtr = objv[i];
3770     varName = TclGetString(objPtr);
3771    
3772     /*
3773     * The variable name might have a scope qualifier, but the name for
3774     * the local "link" variable must be the simple name at the tail.
3775     */
3776    
3777     for (tail = varName; *tail != '\0'; tail++) {
3778     /* empty body */
3779     }
3780     while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
3781     tail--;
3782     }
3783     if (*tail == ':') {
3784     tail++;
3785     }
3786    
3787     /*
3788     * Link to the variable "varName" in the global :: namespace.
3789     */
3790    
3791     result = MakeUpvar(iPtr, (CallFrame *) NULL,
3792     varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
3793     /*myName*/ tail, /*myFlags*/ 0);
3794     if (result != TCL_OK) {
3795     return result;
3796     }
3797     }
3798     return TCL_OK;
3799     }
3800    
3801     /*
3802     *----------------------------------------------------------------------
3803     *
3804     * Tcl_VariableObjCmd --
3805     *
3806     * Invoked to implement the "variable" command that creates one or more
3807     * global variables. Handles the following syntax:
3808     *
3809     * variable ?name value...? name ?value?
3810     *
3811     * One or more variables can be created. The variables are initialized
3812     * with the specified values. The value for the last variable is
3813     * optional.
3814     *
3815     * If the variable does not exist, it is created and given the optional
3816     * value. If it already exists, it is simply set to the optional
3817     * value. Normally, "name" is an unqualified name, so it is created in
3818     * the current namespace. If it includes namespace qualifiers, it can
3819     * be created in another namespace.
3820     *
3821     * If the variable command is executed inside a Tcl procedure, it
3822     * creates a local variable linked to the newly-created namespace
3823     * variable.
3824     *
3825     * Results:
3826     * Returns TCL_OK if the variable is found or created. Returns
3827     * TCL_ERROR if anything goes wrong.
3828     *
3829     * Side effects:
3830     * If anything goes wrong, this procedure returns an error message
3831     * as the result in the interpreter's result object.
3832     *
3833     *----------------------------------------------------------------------
3834     */
3835    
3836     int
3837     Tcl_VariableObjCmd(dummy, interp, objc, objv)
3838     ClientData dummy; /* Not used. */
3839     Tcl_Interp *interp; /* Current interpreter. */
3840     int objc; /* Number of arguments. */
3841     Tcl_Obj *CONST objv[]; /* Argument objects. */
3842     {
3843     Interp *iPtr = (Interp *) interp;
3844     char *varName, *tail, *cp;
3845     Var *varPtr, *arrayPtr;
3846     Tcl_Obj *varValuePtr;
3847     int i, result;
3848    
3849     for (i = 1; i < objc; i = i+2) {
3850     /*
3851     * Look up each variable in the current namespace context, creating
3852     * it if necessary.
3853     */
3854    
3855     varName = TclGetString(objv[i]);
3856     varPtr = TclLookupVar(interp, varName, (char *) NULL,
3857     (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
3858     /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
3859    
3860     if (arrayPtr != NULL) {
3861     /*
3862     * Variable cannot be an element in an array. If arrayPtr is
3863     * non-null, it is, so throw up an error and return.
3864     */
3865     VarErrMsg(interp, varName, NULL, "define", isArrayElement);
3866     return TCL_ERROR;
3867     }
3868    
3869     if (varPtr == NULL) {
3870     return TCL_ERROR;
3871     }
3872    
3873     /*
3874     * Mark the variable as a namespace variable and increment its
3875     * reference count so that it will persist until its namespace is
3876     * destroyed or until the variable is unset.
3877     */
3878    
3879     if (!(varPtr->flags & VAR_NAMESPACE_VAR)) {
3880     varPtr->flags |= VAR_NAMESPACE_VAR;
3881     varPtr->refCount++;
3882     }
3883    
3884     /*
3885     * If a value was specified, set the variable to that value.
3886     * Otherwise, if the variable is new, leave it undefined.
3887     * (If the variable already exists and no value was specified,
3888