![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to tclvar.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Micropolis - Activity] / micropolis / src / tcl|
Return to tclvar.c CVS log | Up to [Micropolis - Activity] / micropolis / src / tcl |
1.1 root 1: /*
2: * tclVar.c --
3: *
4: * This file contains routines that implement Tcl variables
5: * (both scalars and arrays).
6: *
7: * The implementation of arrays is modelled after an initial
8: * implementation by Karl Lehenbauer, Mark Diekhans and
9: * Peter da Silva.
10: *
11: * Copyright 1987-1991 Regents of the University of California
12: * Permission to use, copy, modify, and distribute this
13: * software and its documentation for any purpose and without
14: * fee is hereby granted, provided that the above copyright
15: * notice appear in all copies. The University of California
16: * makes no representations about the suitability of this
17: * software for any purpose. It is provided "as is" without
18: * express or implied warranty.
19: */
20:
21: #ifndef lint
22: static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.27 92/05/07 09:24:59 ouster Exp $ SPRITE (Berkeley)";
23: #endif
24:
25: #include "tclint.h"
26:
27: /*
28: * The strings below are used to indicate what went wrong when a
29: * variable access is denied.
30: */
31:
32: static char *noSuchVar = "no such variable";
33: static char *isArray = "variable is array";
34: static char *needArray = "variable isn't array";
35: static char *noSuchElement = "no such element in array";
36: static char *traceActive = "trace is active on variable";
37:
38: /*
39: * Forward references to procedures defined later in this file:
40: */
41:
42: static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
43: Tcl_HashEntry *hPtr, char *name1, char *name2,
44: int flags));
45: static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
46: static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
47: Var *varPtr, int flags));
48: static Var * NewVar _ANSI_ARGS_((int space));
49: static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
50: Var *varPtr, char *varName, char *string));
51: static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
52: char *name1, char *name2, char *operation,
53: char *reason));
54:
55: /*
56: *----------------------------------------------------------------------
57: *
58: * Tcl_GetVar --
59: *
60: * Return the value of a Tcl variable.
61: *
62: * Results:
63: * The return value points to the current value of varName. If
64: * the variable is not defined or can't be read because of a clash
65: * in array usage then a NULL pointer is returned and an error
66: * message is left in interp->result if the TCL_LEAVE_ERR_MSG
67: * flag is set. Note: the return value is only valid up until
68: * the next call to Tcl_SetVar or Tcl_SetVar2; if you depend on
69: * the value lasting longer than that, then make yourself a private
70: * copy.
71: *
72: * Side effects:
73: * None.
74: *
75: *----------------------------------------------------------------------
76: */
77:
78: char *
79: Tcl_GetVar(interp, varName, flags)
80: Tcl_Interp *interp; /* Command interpreter in which varName is
81: * to be looked up. */
82: char *varName; /* Name of a variable in interp. */
83: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY
84: * or TCL_LEAVE_ERR_MSG bits. */
85: {
86: register char *p;
87:
88: /*
89: * If varName refers to an array (it ends with a parenthesized
90: * element name), then handle it specially.
91: */
92:
93: for (p = varName; *p != '\0'; p++) {
94: if (*p == '(') {
95: char *result;
96: char *open = p;
97:
98: do {
99: p++;
100: } while (*p != '\0');
101: p--;
102: if (*p != ')') {
103: goto scalar;
104: }
105: *open = '\0';
106: *p = '\0';
107: result = Tcl_GetVar2(interp, varName, open + 1, flags);
108: *open = '(';
109: *p = ')';
110: #ifdef sgi
111: strcmp("a", "b"); /* XXX SGI compiler optimizer bug */
112: #endif
113: return result;
114: }
115: }
116:
117: scalar:
118: return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
119: }
120:
121: /*
122: *----------------------------------------------------------------------
123: *
124: * Tcl_GetVar2 --
125: *
126: * Return the value of a Tcl variable, given a two-part name
127: * consisting of array name and element within array.
128: *
129: * Results:
130: * The return value points to the current value of the variable
131: * given by name1 and name2. If the specified variable doesn't
132: * exist, or if there is a clash in array usage, then NULL is
133: * returned and a message will be left in interp->result if the
134: * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is
135: * only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
136: * if you depend on the value lasting longer than that, then make
137: * yourself a private copy.
138: *
139: * Side effects:
140: * None.
141: *
142: *----------------------------------------------------------------------
143: */
144:
145: char *
146: Tcl_GetVar2(interp, name1, name2, flags)
147: Tcl_Interp *interp; /* Command interpreter in which variable is
148: * to be looked up. */
149: char *name1; /* Name of array (if name2 is NULL) or
150: * name of variable. */
151: char *name2; /* If non-null, gives name of element in
152: * array. */
153: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY
154: * or TCL_LEAVE_ERR_MSG bits. */
155: {
156: Tcl_HashEntry *hPtr;
157: Var *varPtr;
158: Interp *iPtr = (Interp *) interp;
159: Var *arrayPtr = NULL;
160:
161: /*
162: * Lookup the first name.
163: */
164:
165: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
166: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
167: } else {
168: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
169: }
170: if (hPtr == NULL) {
171: if (flags & TCL_LEAVE_ERR_MSG) {
172: VarErrMsg(interp, name1, name2, "read", noSuchVar);
173: }
174: return NULL;
175: }
176: varPtr = (Var *) Tcl_GetHashValue(hPtr);
177: if (varPtr->flags & VAR_UPVAR) {
178: hPtr = varPtr->value.upvarPtr;
179: varPtr = (Var *) Tcl_GetHashValue(hPtr);
180: }
181:
182: /*
183: * If this is an array reference, then remember the traces on the array
184: * and lookup the element within the array.
185: */
186:
187: if (name2 != NULL) {
188: if (varPtr->flags & VAR_UNDEFINED) {
189: if (flags & TCL_LEAVE_ERR_MSG) {
190: VarErrMsg(interp, name1, name2, "read", noSuchVar);
191: }
192: return NULL;
193: } else if (!(varPtr->flags & VAR_ARRAY)) {
194: if (flags & TCL_LEAVE_ERR_MSG) {
195: VarErrMsg(interp, name1, name2, "read", needArray);
196: }
197: return NULL;
198: }
199: arrayPtr = varPtr;
200: hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
201: if (hPtr == NULL) {
202: if (flags & TCL_LEAVE_ERR_MSG) {
203: VarErrMsg(interp, name1, name2, "read", noSuchElement);
204: }
205: return NULL;
206: }
207: varPtr = (Var *) Tcl_GetHashValue(hPtr);
208: }
209:
210: /*
211: * Invoke any traces that have been set for the variable.
212: */
213:
214: if ((varPtr->tracePtr != NULL)
215: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
216: char *msg;
217:
218: msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
219: (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
220: if (msg != NULL) {
221: VarErrMsg(interp, name1, name2, "read", msg);
222: return NULL;
223: }
224:
225: /*
226: * Watch out! The variable could have gotten re-allocated to
227: * a larger size. Fortunately the hash table entry will still
228: * be around.
229: */
230:
231: varPtr = (Var *) Tcl_GetHashValue(hPtr);
232: }
233: if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
234: if (flags & TCL_LEAVE_ERR_MSG) {
235: VarErrMsg(interp, name1, name2, "read", noSuchVar);
236: }
237: return NULL;
238: }
239: return varPtr->value.string;
240: }
241:
242: /*
243: *----------------------------------------------------------------------
244: *
245: * Tcl_SetVar --
246: *
247: * Change the value of a variable.
248: *
249: * Results:
250: * Returns a pointer to the malloc'ed string holding the new
251: * value of the variable. The caller should not modify this
252: * string. If the write operation was disallowed then NULL
253: * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then
254: * an explanatory message will be left in interp->result.
255: *
256: * Side effects:
257: * If varName is defined as a local or global variable in interp,
258: * its value is changed to newValue. If varName isn't currently
259: * defined, then a new global variable by that name is created.
260: *
261: *----------------------------------------------------------------------
262: */
263:
264: char *
265: Tcl_SetVar(interp, varName, newValue, flags)
266: Tcl_Interp *interp; /* Command interpreter in which varName is
267: * to be looked up. */
268: char *varName; /* Name of a variable in interp. */
269: char *newValue; /* New value for varName. */
270: int flags; /* Various flags that tell how to set value:
271: * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
272: * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
273: * TCL_LEAVE_ERR_MSG. */
274: {
275: register char *p;
276:
277: /*
278: * If varName refers to an array (it ends with a parenthesized
279: * element name), then handle it specially.
280: */
281:
282: for (p = varName; *p != '\0'; p++) {
283: if (*p == '(') {
284: char *result;
285: char *open = p;
286:
287: do {
288: p++;
289: } while (*p != '\0');
290: p--;
291: if (*p != ')') {
292: goto scalar;
293: }
294: *open = '\0';
295: *p = '\0';
296: result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
297: *open = '(';
298: *p = ')';
299: return result;
300: }
301: }
302:
303: scalar:
304: return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
305: }
306:
307: /*
308: *----------------------------------------------------------------------
309: *
310: * Tcl_SetVar2 --
311: *
312: * Given a two-part variable name, which may refer either to a
313: * scalar variable or an element of an array, change the value
314: * of the variable. If the named scalar or array or element
315: * doesn't exist then create one.
316: *
317: * Results:
318: * Returns a pointer to the malloc'ed string holding the new
319: * value of the variable. The caller should not modify this
320: * string. If the write operation was disallowed because an
321: * array was expected but not found (or vice versa), then NULL
322: * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then
323: * an explanatory message will be left in interp->result.
324: *
325: * Side effects:
326: * The value of the given variable is set. If either the array
327: * or the entry didn't exist then a new one is created.
328: *
329: *----------------------------------------------------------------------
330: */
331:
332: char *
333: Tcl_SetVar2(interp, name1, name2, newValue, flags)
334: Tcl_Interp *interp; /* Command interpreter in which variable is
335: * to be looked up. */
336: char *name1; /* If name2 is NULL, this is name of scalar
337: * variable. Otherwise it is name of array. */
338: char *name2; /* Name of an element within array, or NULL. */
339: char *newValue; /* New value for variable. */
340: int flags; /* Various flags that tell how to set value:
341: * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
342: * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
343: * TCL_LEAVE_ERR_MSG . */
344: {
345: Tcl_HashEntry *hPtr;
346: register Var *varPtr = NULL;
347: /* Initial value only used to stop compiler
348: * from complaining; not really needed. */
349: register Interp *iPtr = (Interp *) interp;
350: int length, new, listFlags;
351: Var *arrayPtr = NULL;
352:
353: /*
354: * Lookup the first name.
355: */
356:
357: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
358: hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
359: } else {
360: hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
361: name1, &new);
362: }
363: if (!new) {
364: varPtr = (Var *) Tcl_GetHashValue(hPtr);
365: if (varPtr->flags & VAR_UPVAR) {
366: hPtr = varPtr->value.upvarPtr;
367: varPtr = (Var *) Tcl_GetHashValue(hPtr);
368: }
369: }
370:
371: /*
372: * If this is an array reference, then create a new array (if
373: * needed), remember any traces on the array, and lookup the
374: * element within the array.
375: */
376:
377: if (name2 != NULL) {
378: if (new) {
379: varPtr = NewVar(0);
380: Tcl_SetHashValue(hPtr, varPtr);
381: varPtr->flags = VAR_ARRAY;
382: varPtr->value.tablePtr = (Tcl_HashTable *)
383: ckalloc(sizeof(Tcl_HashTable));
384: Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
385: } else {
386: if (varPtr->flags & VAR_UNDEFINED) {
387: varPtr->flags = VAR_ARRAY;
388: varPtr->value.tablePtr = (Tcl_HashTable *)
389: ckalloc(sizeof(Tcl_HashTable));
390: Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
391: } else if (!(varPtr->flags & VAR_ARRAY)) {
392: if (flags & TCL_LEAVE_ERR_MSG) {
393: VarErrMsg(interp, name1, name2, "set", needArray);
394: }
395: return NULL;
396: }
397: arrayPtr = varPtr;
398: }
399: hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
400: }
401:
402: /*
403: * Compute how many bytes will be needed for newValue (leave space
404: * for a separating space between list elements).
405: */
406:
407: if (flags & TCL_LIST_ELEMENT) {
408: length = Tcl_ScanElement(newValue, &listFlags) + 1;
409: } else {
410: length = strlen(newValue);
411: }
412:
413: /*
414: * If the variable doesn't exist then create a new one. If it
415: * does exist then clear its current value unless this is an
416: * append operation.
417: */
418:
419: if (new) {
420: varPtr = NewVar(length);
421: Tcl_SetHashValue(hPtr, varPtr);
422: if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
423: DeleteSearches(arrayPtr);
424: }
425: } else {
426: varPtr = (Var *) Tcl_GetHashValue(hPtr);
427: if (varPtr->flags & VAR_ARRAY) {
428: if (flags & TCL_LEAVE_ERR_MSG) {
429: VarErrMsg(interp, name1, name2, "set", isArray);
430: }
431: return NULL;
432: }
433: if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
434: varPtr->valueLength = 0;
435: }
436: }
437:
438: /*
439: * Make sure there's enough space to hold the variable's
440: * new value. If not, enlarge the variable's space.
441: */
442:
443: if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
444: Var *newVarPtr;
445: int newSize;
446:
447: newSize = 2*varPtr->valueSpace;
448: if (newSize <= (length + varPtr->valueLength)) {
449: newSize += length;
450: }
451: newVarPtr = NewVar(newSize);
452: newVarPtr->valueLength = varPtr->valueLength;
453: newVarPtr->upvarUses = varPtr->upvarUses;
454: newVarPtr->tracePtr = varPtr->tracePtr;
455: strcpy(newVarPtr->value.string, varPtr->value.string);
456: Tcl_SetHashValue(hPtr, newVarPtr);
457: ckfree((char *) varPtr);
458: varPtr = newVarPtr;
459: }
460:
461: /*
462: * Append the new value to the variable, either as a list
463: * element or as a string.
464: */
465:
466: if (flags & TCL_LIST_ELEMENT) {
467: if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
468: varPtr->value.string[varPtr->valueLength] = ' ';
469: varPtr->valueLength++;
470: }
471: varPtr->valueLength += Tcl_ConvertElement(newValue,
472: varPtr->value.string + varPtr->valueLength, listFlags);
473: varPtr->value.string[varPtr->valueLength] = 0;
474: } else {
475: strcpy(varPtr->value.string + varPtr->valueLength, newValue);
476: varPtr->valueLength += length;
477: }
478: varPtr->flags &= ~VAR_UNDEFINED;
479:
480: /*
481: * Invoke any write traces for the variable.
482: */
483:
484: if ((varPtr->tracePtr != NULL)
485: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
486: char *msg;
487:
488: msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
489: (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
490: if (msg != NULL) {
491: VarErrMsg(interp, name1, name2, "set", msg);
492: return NULL;
493: }
494:
495: /*
496: * Watch out! The variable could have gotten re-allocated to
497: * a larger size. Fortunately the hash table entry will still
498: * be around.
499: */
500:
501: varPtr = (Var *) Tcl_GetHashValue(hPtr);
502: }
503: return varPtr->value.string;
504: }
505:
506: /*
507: *----------------------------------------------------------------------
508: *
509: * Tcl_UnsetVar --
510: *
511: * Delete a variable, so that it may not be accessed anymore.
512: *
513: * Results:
514: * Returns 0 if the variable was successfully deleted, -1
515: * if the variable can't be unset. In the event of an error,
516: * if the TCL_LEAVE_ERR_MSG flag is set then an error message
517: * is left in interp->result.
518: *
519: * Side effects:
520: * If varName is defined as a local or global variable in interp,
521: * it is deleted.
522: *
523: *----------------------------------------------------------------------
524: */
525:
526: int
527: Tcl_UnsetVar(interp, varName, flags)
528: Tcl_Interp *interp; /* Command interpreter in which varName is
529: * to be looked up. */
530: char *varName; /* Name of a variable in interp. May be
531: * either a scalar name or an array name
532: * or an element in an array. */
533: int flags; /* OR-ed combination of any of
534: * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
535: {
536: register char *p;
537: int result;
538:
539: /*
540: * Figure out whether this is an array reference, then call
541: * Tcl_UnsetVar2 to do all the real work.
542: */
543:
544: for (p = varName; *p != '\0'; p++) {
545: if (*p == '(') {
546: char *open = p;
547:
548: do {
549: p++;
550: } while (*p != '\0');
551: p--;
552: if (*p != ')') {
553: goto scalar;
554: }
555: *open = '\0';
556: *p = '\0';
557: result = Tcl_UnsetVar2(interp, varName, open+1, flags);
558: *open = '(';
559: *p = ')';
560: return result;
561: }
562: }
563:
564: scalar:
565: return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
566: }
567:
568: /*
569: *----------------------------------------------------------------------
570: *
571: * Tcl_UnsetVar2 --
572: *
573: * Delete a variable, given a 2-part name.
574: *
575: * Results:
576: * Returns 0 if the variable was successfully deleted, -1
577: * if the variable can't be unset. In the event of an error,
578: * if the TCL_LEAVE_ERR_MSG flag is set then an error message
579: * is left in interp->result.
580: *
581: * Side effects:
582: * If name1 and name2 indicate a local or global variable in interp,
583: * it is deleted. If name1 is an array name and name2 is NULL, then
584: * the whole array is deleted.
585: *
586: *----------------------------------------------------------------------
587: */
588:
589: int
590: Tcl_UnsetVar2(interp, name1, name2, flags)
591: Tcl_Interp *interp; /* Command interpreter in which varName is
592: * to be looked up. */
593: char *name1; /* Name of variable or array. */
594: char *name2; /* Name of element within array or NULL. */
595: int flags; /* OR-ed combination of any of
596: * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
597: {
598: Tcl_HashEntry *hPtr, dummyEntry;
599: Var *varPtr, dummyVar;
600: Interp *iPtr = (Interp *) interp;
601: Var *arrayPtr = NULL;
602:
603: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
604: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
605: } else {
606: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
607: }
608: if (hPtr == NULL) {
609: if (flags & TCL_LEAVE_ERR_MSG) {
610: VarErrMsg(interp, name1, name2, "unset", noSuchVar);
611: }
612: return -1;
613: }
614: varPtr = (Var *) Tcl_GetHashValue(hPtr);
615:
616: /*
617: * For global variables referenced in procedures, leave the procedure's
618: * reference variable in place, but unset the global variable. Can't
619: * decrement the actual variable's use count, since we didn't delete
620: * the reference variable.
621: */
622:
623: if (varPtr->flags & VAR_UPVAR) {
624: hPtr = varPtr->value.upvarPtr;
625: varPtr = (Var *) Tcl_GetHashValue(hPtr);
626: }
627:
628: /*
629: * If the variable being deleted is an element of an array, then
630: * remember trace procedures on the overall array and find the
631: * element to delete.
632: */
633:
634: if (name2 != NULL) {
635: if (!(varPtr->flags & VAR_ARRAY)) {
636: if (flags & TCL_LEAVE_ERR_MSG) {
637: VarErrMsg(interp, name1, name2, "unset", needArray);
638: }
639: return -1;
640: }
641: if (varPtr->searchPtr != NULL) {
642: DeleteSearches(varPtr);
643: }
644: arrayPtr = varPtr;
645: hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
646: if (hPtr == NULL) {
647: if (flags & TCL_LEAVE_ERR_MSG) {
648: VarErrMsg(interp, name1, name2, "unset", noSuchElement);
649: }
650: return -1;
651: }
652: varPtr = (Var *) Tcl_GetHashValue(hPtr);
653: }
654:
655: /*
656: * If there is a trace active on this variable or if the variable
657: * is already being deleted then don't delete the variable: it
658: * isn't safe, since there are procedures higher up on the stack
659: * that will use pointers to the variable. Also don't delete an
660: * array if there are traces active on any of its elements.
661: */
662:
663: if (varPtr->flags &
664: (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
665: if (flags & TCL_LEAVE_ERR_MSG) {
666: VarErrMsg(interp, name1, name2, "unset", traceActive);
667: }
668: return -1;
669: }
670:
671: /*
672: * The code below is tricky, because of the possibility that
673: * a trace procedure might try to access a variable being
674: * deleted. To handle this situation gracefully, copy the
675: * contents of the variable and its hash table entry to
676: * dummy variables, then clean up the actual variable so that
677: * it's been completely deleted before the traces are called.
678: * Then call the traces, and finally clean up the variable's
679: * storage using the dummy copies.
680: */
681:
682: dummyVar = *varPtr;
683: Tcl_SetHashValue(&dummyEntry, &dummyVar);
684: if (varPtr->upvarUses == 0) {
685: Tcl_DeleteHashEntry(hPtr);
686: ckfree((char *) varPtr);
687: } else {
688: varPtr->flags = VAR_UNDEFINED;
689: varPtr->tracePtr = NULL;
690: }
691:
692: /*
693: * Call trace procedures for the variable being deleted and delete
694: * its traces.
695: */
696:
697: if ((dummyVar.tracePtr != NULL)
698: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
699: (void) CallTraces(iPtr, arrayPtr, &dummyEntry, name1, name2,
700: (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
701: while (dummyVar.tracePtr != NULL) {
702: VarTrace *tracePtr = dummyVar.tracePtr;
703: dummyVar.tracePtr = tracePtr->nextPtr;
704: ckfree((char *) tracePtr);
705: }
706: }
707:
708: /*
709: * If the variable is an array, delete all of its elements. This
710: * must be done after calling the traces on the array, above (that's
711: * the way traces are defined).
712: */
713:
714: if (dummyVar.flags & VAR_ARRAY) {
715: DeleteArray(iPtr, name1, &dummyVar,
716: (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
717: }
718: if (dummyVar.flags & VAR_UNDEFINED) {
719: if (flags & TCL_LEAVE_ERR_MSG) {
720: VarErrMsg(interp, name1, name2, "unset",
721: (name2 == NULL) ? noSuchVar : noSuchElement);
722: }
723: return -1;
724: }
725: return 0;
726: }
727:
728: /*
729: *----------------------------------------------------------------------
730: *
731: * Tcl_TraceVar --
732: *
733: * Arrange for reads and/or writes to a variable to cause a
734: * procedure to be invoked, which can monitor the operations
735: * and/or change their actions.
736: *
737: * Results:
738: * A standard Tcl return value.
739: *
740: * Side effects:
741: * A trace is set up on the variable given by varName, such that
742: * future references to the variable will be intermediated by
743: * proc. See the manual entry for complete details on the calling
744: * sequence for proc.
745: *
746: *----------------------------------------------------------------------
747: */
748:
749: int
750: Tcl_TraceVar(interp, varName, flags, proc, clientData)
751: Tcl_Interp *interp; /* Interpreter in which variable is
752: * to be traced. */
753: char *varName; /* Name of variable; may end with "(index)"
754: * to signify an array reference. */
755: int flags; /* OR-ed collection of bits, including any
756: * of TCL_TRACE_READS, TCL_TRACE_WRITES,
757: * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
758: Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
759: * invoked upon varName. */
760: ClientData clientData; /* Arbitrary argument to pass to proc. */
761: {
762: register char *p;
763:
764: /*
765: * If varName refers to an array (it ends with a parenthesized
766: * element name), then handle it specially.
767: */
768:
769: for (p = varName; *p != '\0'; p++) {
770: if (*p == '(') {
771: int result;
772: char *open = p;
773:
774: do {
775: p++;
776: } while (*p != '\0');
777: p--;
778: if (*p != ')') {
779: goto scalar;
780: }
781: *open = '\0';
782: *p = '\0';
783: result = Tcl_TraceVar2(interp, varName, open+1, flags,
784: proc, clientData);
785: *open = '(';
786: *p = ')';
787: return result;
788: }
789: }
790:
791: scalar:
792: return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
793: proc, clientData);
794: }
795:
796: /*
797: *----------------------------------------------------------------------
798: *
799: * Tcl_TraceVar2 --
800: *
801: * Arrange for reads and/or writes to a variable to cause a
802: * procedure to be invoked, which can monitor the operations
803: * and/or change their actions.
804: *
805: * Results:
806: * A standard Tcl return value.
807: *
808: * Side effects:
809: * A trace is set up on the variable given by name1 and name2, such
810: * that future references to the variable will be intermediated by
811: * proc. See the manual entry for complete details on the calling
812: * sequence for proc.
813: *
814: *----------------------------------------------------------------------
815: */
816:
817: int
818: Tcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
819: Tcl_Interp *interp; /* Interpreter in which variable is
820: * to be traced. */
821: char *name1; /* Name of scalar variable or array. */
822: char *name2; /* Name of element within array; NULL means
823: * trace applies to scalar variable or array
824: * as-a-whole. */
825: int flags; /* OR-ed collection of bits, including any
826: * of TCL_TRACE_READS, TCL_TRACE_WRITES,
827: * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
828: Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
829: * invoked upon varName. */
830: ClientData clientData; /* Arbitrary argument to pass to proc. */
831: {
832: Tcl_HashEntry *hPtr;
833: Var *varPtr = NULL; /* Initial value only used to stop compiler
834: * from complaining; not really needed. */
835: Interp *iPtr = (Interp *) interp;
836: register VarTrace *tracePtr;
837: int new;
838:
839: /*
840: * Locate the variable, making a new (undefined) one if necessary.
841: */
842:
843: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
844: hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
845: } else {
846: hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, name1, &new);
847: }
848: if (!new) {
849: varPtr = (Var *) Tcl_GetHashValue(hPtr);
850: if (varPtr->flags & VAR_UPVAR) {
851: hPtr = varPtr->value.upvarPtr;
852: varPtr = (Var *) Tcl_GetHashValue(hPtr);
853: }
854: }
855:
856: /*
857: * If the trace is to be on an array element, make sure that the
858: * variable is an array variable. If the variable doesn't exist
859: * then define it as an empty array. Then find the specific
860: * array element.
861: */
862:
863: if (name2 != NULL) {
864: if (new) {
865: varPtr = NewVar(0);
866: Tcl_SetHashValue(hPtr, varPtr);
867: varPtr->flags = VAR_ARRAY;
868: varPtr->value.tablePtr = (Tcl_HashTable *)
869: ckalloc(sizeof(Tcl_HashTable));
870: Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
871: } else {
872: if (varPtr->flags & VAR_UNDEFINED) {
873: varPtr->flags = VAR_ARRAY;
874: varPtr->value.tablePtr = (Tcl_HashTable *)
875: ckalloc(sizeof(Tcl_HashTable));
876: Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
877: } else if (!(varPtr->flags & VAR_ARRAY)) {
878: iPtr->result = needArray;
879: return TCL_ERROR;
880: }
881: }
882: hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
883: }
884:
885: if (new) {
886: if ((name2 != NULL) && (varPtr->searchPtr != NULL)) {
887: DeleteSearches(varPtr);
888: }
889: varPtr = NewVar(0);
890: varPtr->flags = VAR_UNDEFINED;
891: Tcl_SetHashValue(hPtr, varPtr);
892: } else {
893: varPtr = (Var *) Tcl_GetHashValue(hPtr);
894: }
895:
896: /*
897: * Set up trace information.
898: */
899:
900: tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
901: tracePtr->traceProc = proc;
902: tracePtr->clientData = clientData;
903: tracePtr->flags = flags &
904: (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
905: tracePtr->nextPtr = varPtr->tracePtr;
906: varPtr->tracePtr = tracePtr;
907: return TCL_OK;
908: }
909:
910: /*
911: *----------------------------------------------------------------------
912: *
913: * Tcl_UntraceVar --
914: *
915: * Remove a previously-created trace for a variable.
916: *
917: * Results:
918: * None.
919: *
920: * Side effects:
921: * If there exists a trace for the variable given by varName
922: * with the given flags, proc, and clientData, then that trace
923: * is removed.
924: *
925: *----------------------------------------------------------------------
926: */
927:
928: void
929: Tcl_UntraceVar(interp, varName, flags, proc, clientData)
930: Tcl_Interp *interp; /* Interpreter containing traced variable. */
931: char *varName; /* Name of variable; may end with "(index)"
932: * to signify an array reference. */
933: int flags; /* OR-ed collection of bits describing
934: * current trace, including any of
935: * TCL_TRACE_READS, TCL_TRACE_WRITES,
936: * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
937: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
938: ClientData clientData; /* Arbitrary argument to pass to proc. */
939: {
940: register char *p;
941:
942: /*
943: * If varName refers to an array (it ends with a parenthesized
944: * element name), then handle it specially.
945: */
946:
947: for (p = varName; *p != '\0'; p++) {
948: if (*p == '(') {
949: char *open = p;
950:
951: do {
952: p++;
953: } while (*p != '\0');
954: p--;
955: if (*p != ')') {
956: goto scalar;
957: }
958: *open = '\0';
959: *p = '\0';
960: Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
961: *open = '(';
962: *p = ')';
963: return;
964: }
965: }
966:
967: scalar:
968: Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
969: }
970:
971: /*
972: *----------------------------------------------------------------------
973: *
974: * Tcl_UntraceVar2 --
975: *
976: * Remove a previously-created trace for a variable.
977: *
978: * Results:
979: * None.
980: *
981: * Side effects:
982: * If there exists a trace for the variable given by name1
983: * and name2 with the given flags, proc, and clientData, then
984: * that trace is removed.
985: *
986: *----------------------------------------------------------------------
987: */
988:
989: void
990: Tcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
991: Tcl_Interp *interp; /* Interpreter containing traced variable. */
992: char *name1; /* Name of variable or array. */
993: char *name2; /* Name of element within array; NULL means
994: * trace applies to scalar variable or array
995: * as-a-whole. */
996: int flags; /* OR-ed collection of bits describing
997: * current trace, including any of
998: * TCL_TRACE_READS, TCL_TRACE_WRITES,
999: * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
1000: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1001: ClientData clientData; /* Arbitrary argument to pass to proc. */
1002: {
1003: register VarTrace *tracePtr;
1004: VarTrace *prevPtr;
1005: Var *varPtr;
1006: Interp *iPtr = (Interp *) interp;
1007: Tcl_HashEntry *hPtr;
1008: ActiveVarTrace *activePtr;
1009:
1010: /*
1011: * First, lookup the variable.
1012: */
1013:
1014: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
1015: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
1016: } else {
1017: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
1018: }
1019: if (hPtr == NULL) {
1020: return;
1021: }
1022: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1023: if (varPtr->flags & VAR_UPVAR) {
1024: hPtr = varPtr->value.upvarPtr;
1025: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1026: }
1027: if (name2 != NULL) {
1028: if (!(varPtr->flags & VAR_ARRAY)) {
1029: return;
1030: }
1031: hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
1032: if (hPtr == NULL) {
1033: return;
1034: }
1035: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1036: }
1037:
1038: flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
1039: for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
1040: prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
1041: if (tracePtr == NULL) {
1042: return;
1043: }
1044: if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
1045: && (tracePtr->clientData == clientData)) {
1046: break;
1047: }
1048: }
1049:
1050: /*
1051: * The code below makes it possible to delete traces while traces
1052: * are active: it makes sure that the deleted trace won't be
1053: * processed by CallTraces.
1054: */
1055:
1056: for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
1057: activePtr = activePtr->nextPtr) {
1058: if (activePtr->nextTracePtr == tracePtr) {
1059: activePtr->nextTracePtr = tracePtr->nextPtr;
1060: }
1061: }
1062: if (prevPtr == NULL) {
1063: varPtr->tracePtr = tracePtr->nextPtr;
1064: } else {
1065: prevPtr->nextPtr = tracePtr->nextPtr;
1066: }
1067: ckfree((char *) tracePtr);
1068: }
1069:
1070: /*
1071: *----------------------------------------------------------------------
1072: *
1073: * Tcl_VarTraceInfo --
1074: *
1075: * Return the clientData value associated with a trace on a
1076: * variable. This procedure can also be used to step through
1077: * all of the traces on a particular variable that have the
1078: * same trace procedure.
1079: *
1080: * Results:
1081: * The return value is the clientData value associated with
1082: * a trace on the given variable. Information will only be
1083: * returned for a trace with proc as trace procedure. If
1084: * the clientData argument is NULL then the first such trace is
1085: * returned; otherwise, the next relevant one after the one
1086: * given by clientData will be returned. If the variable
1087: * doesn't exist, or if there are no (more) traces for it,
1088: * then NULL is returned.
1089: *
1090: * Side effects:
1091: * None.
1092: *
1093: *----------------------------------------------------------------------
1094: */
1095:
1096: ClientData
1097: Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
1098: Tcl_Interp *interp; /* Interpreter containing variable. */
1099: char *varName; /* Name of variable; may end with "(index)"
1100: * to signify an array reference. */
1101: int flags; /* 0 or TCL_GLOBAL_ONLY. */
1102: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1103: ClientData prevClientData; /* If non-NULL, gives last value returned
1104: * by this procedure, so this call will
1105: * return the next trace after that one.
1106: * If NULL, this call will return the
1107: * first trace. */
1108: {
1109: register char *p;
1110:
1111: /*
1112: * If varName refers to an array (it ends with a parenthesized
1113: * element name), then handle it specially.
1114: */
1115:
1116: for (p = varName; *p != '\0'; p++) {
1117: if (*p == '(') {
1118: ClientData result;
1119: char *open = p;
1120:
1121: do {
1122: p++;
1123: } while (*p != '\0');
1124: p--;
1125: if (*p != ')') {
1126: goto scalar;
1127: }
1128: *open = '\0';
1129: *p = '\0';
1130: result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
1131: prevClientData);
1132: *open = '(';
1133: *p = ')';
1134: return result;
1135: }
1136: }
1137:
1138: scalar:
1139: return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
1140: prevClientData);
1141: }
1142:
1143: /*
1144: *----------------------------------------------------------------------
1145: *
1146: * Tcl_VarTraceInfo2 --
1147: *
1148: * Same as Tcl_VarTraceInfo, except takes name in two pieces
1149: * instead of one.
1150: *
1151: * Results:
1152: * Same as Tcl_VarTraceInfo.
1153: *
1154: * Side effects:
1155: * None.
1156: *
1157: *----------------------------------------------------------------------
1158: */
1159:
1160: ClientData
1161: Tcl_VarTraceInfo2(interp, name1, name2, flags, proc, prevClientData)
1162: Tcl_Interp *interp; /* Interpreter containing variable. */
1163: char *name1; /* Name of variable or array. */
1164: char *name2; /* Name of element within array; NULL means
1165: * trace applies to scalar variable or array
1166: * as-a-whole. */
1167: int flags; /* 0 or TCL_GLOBAL_ONLY. */
1168: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
1169: ClientData prevClientData; /* If non-NULL, gives last value returned
1170: * by this procedure, so this call will
1171: * return the next trace after that one.
1172: * If NULL, this call will return the
1173: * first trace. */
1174: {
1175: register VarTrace *tracePtr;
1176: Var *varPtr;
1177: Interp *iPtr = (Interp *) interp;
1178: Tcl_HashEntry *hPtr;
1179:
1180: /*
1181: * First, lookup the variable.
1182: */
1183:
1184: if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
1185: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
1186: } else {
1187: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
1188: }
1189: if (hPtr == NULL) {
1190: return NULL;
1191: }
1192: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1193: if (varPtr->flags & VAR_UPVAR) {
1194: hPtr = varPtr->value.upvarPtr;
1195: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1196: }
1197: if (name2 != NULL) {
1198: if (!(varPtr->flags & VAR_ARRAY)) {
1199: return NULL;
1200: }
1201: hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
1202: if (hPtr == NULL) {
1203: return NULL;
1204: }
1205: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1206: }
1207:
1208: /*
1209: * Find the relevant trace, if any, and return its clientData.
1210: */
1211:
1212: tracePtr = varPtr->tracePtr;
1213: if (prevClientData != NULL) {
1214: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
1215: if ((tracePtr->clientData == prevClientData)
1216: && (tracePtr->traceProc == proc)) {
1217: tracePtr = tracePtr->nextPtr;
1218: break;
1219: }
1220: }
1221: }
1222: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
1223: if (tracePtr->traceProc == proc) {
1224: return tracePtr->clientData;
1225: }
1226: }
1227: return NULL;
1228: }
1229:
1230: /*
1231: *----------------------------------------------------------------------
1232: *
1233: * Tcl_SetCmd --
1234: *
1235: * This procedure is invoked to process the "set" Tcl command.
1236: * See the user documentation for details on what it does.
1237: *
1238: * Results:
1239: * A standard Tcl result value.
1240: *
1241: * Side effects:
1242: * A variable's value may be changed.
1243: *
1244: *----------------------------------------------------------------------
1245: */
1246:
1247: /* ARGSUSED */
1248: int
1249: Tcl_SetCmd(dummy, interp, argc, argv)
1250: ClientData dummy; /* Not used. */
1251: register Tcl_Interp *interp; /* Current interpreter. */
1252: int argc; /* Number of arguments. */
1253: char **argv; /* Argument strings. */
1254: {
1255: if (argc == 2) {
1256: char *value;
1257:
1258: value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
1259: if (value == NULL) {
1260: return TCL_ERROR;
1261: }
1262: interp->result = value;
1263: return TCL_OK;
1264: } else if (argc == 3) {
1265: char *result;
1266:
1267: result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
1268: if (result == NULL) {
1269: return TCL_ERROR;
1270: }
1271: interp->result = result;
1272: return TCL_OK;
1273: } else {
1274: Tcl_AppendResult(interp, "wrong # args: should be \"",
1275: argv[0], " varName ?newValue?\"", (char *) NULL);
1276: return TCL_ERROR;
1277: }
1278: }
1279:
1280: /*
1281: *----------------------------------------------------------------------
1282: *
1283: * Tcl_UnsetCmd --
1284: *
1285: * This procedure is invoked to process the "unset" Tcl command.
1286: * See the user documentation for details on what it does.
1287: *
1288: * Results:
1289: * A standard Tcl result value.
1290: *
1291: * Side effects:
1292: * See the user documentation.
1293: *
1294: *----------------------------------------------------------------------
1295: */
1296:
1297: /* ARGSUSED */
1298: int
1299: Tcl_UnsetCmd(dummy, interp, argc, argv)
1300: ClientData dummy; /* Not used. */
1301: register Tcl_Interp *interp; /* Current interpreter. */
1302: int argc; /* Number of arguments. */
1303: char **argv; /* Argument strings. */
1304: {
1305: int i;
1306:
1307: if (argc < 2) {
1308: Tcl_AppendResult(interp, "wrong # args: should be \"",
1309: argv[0], " varName ?varName ...?\"", (char *) NULL);
1310: return TCL_ERROR;
1311: }
1312: for (i = 1; i < argc; i++) {
1313: if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {
1314: return TCL_ERROR;
1315: }
1316: }
1317: return TCL_OK;
1318: }
1319:
1320: /*
1321: *----------------------------------------------------------------------
1322: *
1323: * Tcl_AppendCmd --
1324: *
1325: * This procedure is invoked to process the "append" Tcl command.
1326: * See the user documentation for details on what it does.
1327: *
1328: * Results:
1329: * A standard Tcl result value.
1330: *
1331: * Side effects:
1332: * A variable's value may be changed.
1333: *
1334: *----------------------------------------------------------------------
1335: */
1336:
1337: /* ARGSUSED */
1338: int
1339: Tcl_AppendCmd(dummy, interp, argc, argv)
1340: ClientData dummy; /* Not used. */
1341: register Tcl_Interp *interp; /* Current interpreter. */
1342: int argc; /* Number of arguments. */
1343: char **argv; /* Argument strings. */
1344: {
1345: int i;
1346: char *result = NULL; /* (Initialization only needed to keep
1347: * the compiler from complaining) */
1348:
1349: if (argc < 3) {
1350: Tcl_AppendResult(interp, "wrong # args: should be \"",
1351: argv[0], " varName value ?value ...?\"", (char *) NULL);
1352: return TCL_ERROR;
1353: }
1354:
1355: for (i = 2; i < argc; i++) {
1356: result = Tcl_SetVar(interp, argv[1], argv[i],
1357: TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
1358: if (result == NULL) {
1359: return TCL_ERROR;
1360: }
1361: }
1362: interp->result = result;
1363: return TCL_OK;
1364: }
1365:
1366: /*
1367: *----------------------------------------------------------------------
1368: *
1369: * Tcl_LappendCmd --
1370: *
1371: * This procedure is invoked to process the "lappend" Tcl command.
1372: * See the user documentation for details on what it does.
1373: *
1374: * Results:
1375: * A standard Tcl result value.
1376: *
1377: * Side effects:
1378: * A variable's value may be changed.
1379: *
1380: *----------------------------------------------------------------------
1381: */
1382:
1383: /* ARGSUSED */
1384: int
1385: Tcl_LappendCmd(dummy, interp, argc, argv)
1386: ClientData dummy; /* Not used. */
1387: register Tcl_Interp *interp; /* Current interpreter. */
1388: int argc; /* Number of arguments. */
1389: char **argv; /* Argument strings. */
1390: {
1391: int i;
1392: char *result = NULL; /* (Initialization only needed to keep
1393: * the compiler from complaining) */
1394:
1395: if (argc < 3) {
1396: Tcl_AppendResult(interp, "wrong # args: should be \"",
1397: argv[0], " varName value ?value ...?\"", (char *) NULL);
1398: return TCL_ERROR;
1399: }
1400:
1401: for (i = 2; i < argc; i++) {
1402: result = Tcl_SetVar(interp, argv[1], argv[i],
1403: TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
1404: if (result == NULL) {
1405: return TCL_ERROR;
1406: }
1407: }
1408: interp->result = result;
1409: return TCL_OK;
1410: }
1411:
1412: /*
1413: *----------------------------------------------------------------------
1414: *
1415: * Tcl_ArrayCmd --
1416: *
1417: * This procedure is invoked to process the "array" Tcl command.
1418: * See the user documentation for details on what it does.
1419: *
1420: * Results:
1421: * A standard Tcl result value.
1422: *
1423: * Side effects:
1424: * See the user documentation.
1425: *
1426: *----------------------------------------------------------------------
1427: */
1428:
1429: /* ARGSUSED */
1430: int
1431: Tcl_ArrayCmd(dummy, interp, argc, argv)
1432: ClientData dummy; /* Not used. */
1433: register Tcl_Interp *interp; /* Current interpreter. */
1434: int argc; /* Number of arguments. */
1435: char **argv; /* Argument strings. */
1436: {
1437: int length;
1438: char c;
1439: Var *varPtr;
1440: Tcl_HashEntry *hPtr;
1441: Interp *iPtr = (Interp *) interp;
1442:
1443: if (argc < 3) {
1444: Tcl_AppendResult(interp, "wrong # args: should be \"",
1445: argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
1446: return TCL_ERROR;
1447: }
1448:
1449: /*
1450: * Locate the array variable (and it better be an array).
1451: */
1452:
1453: if (iPtr->varFramePtr == NULL) {
1454: hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
1455: } else {
1456: hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
1457: }
1458: if (hPtr == NULL) {
1459: notArray:
1460: Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
1461: (char *) NULL);
1462: return TCL_ERROR;
1463: }
1464: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1465: if (varPtr->flags & VAR_UPVAR) {
1466: varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
1467: }
1468: if (!(varPtr->flags & VAR_ARRAY)) {
1469: goto notArray;
1470: }
1471:
1472: /*
1473: * Dispatch based on the option.
1474: */
1475:
1476: c = argv[1][0];
1477: length = strlen(argv[1]);
1478: if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
1479: ArraySearch *searchPtr;
1480:
1481: if (argc != 4) {
1482: Tcl_AppendResult(interp, "wrong # args: should be \"",
1483: argv[0], " anymore arrayName searchId\"", (char *) NULL);
1484: return TCL_ERROR;
1485: }
1486: searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
1487: if (searchPtr == NULL) {
1488: return TCL_ERROR;
1489: }
1490: while (1) {
1491: Var *varPtr2;
1492:
1493: if (searchPtr->nextEntry != NULL) {
1494: varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
1495: if (!(varPtr2->flags & VAR_UNDEFINED)) {
1496: break;
1497: }
1498: }
1499: searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
1500: if (searchPtr->nextEntry == NULL) {
1501: interp->result = "0";
1502: return TCL_OK;
1503: }
1504: }
1505: interp->result = "1";
1506: return TCL_OK;
1507: } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
1508: ArraySearch *searchPtr, *prevPtr;
1509:
1510: if (argc != 4) {
1511: Tcl_AppendResult(interp, "wrong # args: should be \"",
1512: argv[0], " donesearch arrayName searchId\"", (char *) NULL);
1513: return TCL_ERROR;
1514: }
1515: searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
1516: if (searchPtr == NULL) {
1517: return TCL_ERROR;
1518: }
1519: if (varPtr->searchPtr == searchPtr) {
1520: varPtr->searchPtr = searchPtr->nextPtr;
1521: } else {
1522: for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
1523: if (prevPtr->nextPtr == searchPtr) {
1524: prevPtr->nextPtr = searchPtr->nextPtr;
1525: break;
1526: }
1527: }
1528: }
1529: ckfree((char *) searchPtr);
1530: } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
1531: && (length >= 2)) {
1532: Tcl_HashSearch search;
1533: Var *varPtr2;
1534:
1535: if (argc != 3) {
1536: Tcl_AppendResult(interp, "wrong # args: should be \"",
1537: argv[0], " names arrayName\"", (char *) NULL);
1538: return TCL_ERROR;
1539: }
1540: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
1541: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1542: varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1543: if (varPtr2->flags & VAR_UNDEFINED) {
1544: continue;
1545: }
1546: Tcl_AppendElement(interp,
1547: Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
1548: }
1549: } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
1550: && (length >= 2)) {
1551: ArraySearch *searchPtr;
1552: Tcl_HashEntry *hPtr;
1553:
1554: if (argc != 4) {
1555: Tcl_AppendResult(interp, "wrong # args: should be \"",
1556: argv[0], " nextelement arrayName searchId\"",
1557: (char *) NULL);
1558: return TCL_ERROR;
1559: }
1560: searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
1561: if (searchPtr == NULL) {
1562: return TCL_ERROR;
1563: }
1564: while (1) {
1565: Var *varPtr2;
1566:
1567: hPtr = searchPtr->nextEntry;
1568: if (hPtr == NULL) {
1569: hPtr = Tcl_NextHashEntry(&searchPtr->search);
1570: if (hPtr == NULL) {
1571: return TCL_OK;
1572: }
1573: } else {
1574: searchPtr->nextEntry = NULL;
1575: }
1576: varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1577: if (!(varPtr2->flags & VAR_UNDEFINED)) {
1578: break;
1579: }
1580: }
1581: interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
1582: } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
1583: && (length >= 2)) {
1584: Tcl_HashSearch search;
1585: Var *varPtr2;
1586: int size;
1587:
1588: if (argc != 3) {
1589: Tcl_AppendResult(interp, "wrong # args: should be \"",
1590: argv[0], " size arrayName\"", (char *) NULL);
1591: return TCL_ERROR;
1592: }
1593: size = 0;
1594: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
1595: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
1596: varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
1597: if (varPtr2->flags & VAR_UNDEFINED) {
1598: continue;
1599: }
1600: size++;
1601: }
1602: sprintf(interp->result, "%d", size);
1603: } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
1604: && (length >= 2)) {
1605: ArraySearch *searchPtr;
1606:
1607: if (argc != 3) {
1608: Tcl_AppendResult(interp, "wrong # args: should be \"",
1609: argv[0], " startsearch arrayName\"", (char *) NULL);
1610: return TCL_ERROR;
1611: }
1612: searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
1613: if (varPtr->searchPtr == NULL) {
1614: searchPtr->id = 1;
1615: Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
1616: } else {
1617: char string[20];
1618:
1619: searchPtr->id = varPtr->searchPtr->id + 1;
1620: sprintf(string, "%d", searchPtr->id);
1621: Tcl_AppendResult(interp, "s-", string, "-", argv[2],
1622: (char *) NULL);
1623: }
1624: searchPtr->varPtr = varPtr;
1625: searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
1626: &searchPtr->search);
1627: searchPtr->nextPtr = varPtr->searchPtr;
1628: varPtr->searchPtr = searchPtr;
1629: } else {
1630: Tcl_AppendResult(interp, "bad option \"", argv[1],
1631: "\": should be anymore, donesearch, names, nextelement, ",
1632: "size, or startsearch", (char *) NULL);
1633: return TCL_ERROR;
1634: }
1635: return TCL_OK;
1636: }
1637:
1638: /*
1639: *----------------------------------------------------------------------
1640: *
1641: * Tcl_GlobalCmd --
1642: *
1643: * This procedure is invoked to process the "global" Tcl command.
1644: * See the user documentation for details on what it does.
1645: *
1646: * Results:
1647: * A standard Tcl result value.
1648: *
1649: * Side effects:
1650: * See the user documentation.
1651: *
1652: *----------------------------------------------------------------------
1653: */
1654:
1655: /* ARGSUSED */
1656: int
1657: Tcl_GlobalCmd(dummy, interp, argc, argv)
1658: ClientData dummy; /* Not used. */
1659: Tcl_Interp *interp; /* Current interpreter. */
1660: int argc; /* Number of arguments. */
1661: char **argv; /* Argument strings. */
1662: {
1663: Var *varPtr, *gVarPtr;
1664: register Interp *iPtr = (Interp *) interp;
1665: Tcl_HashEntry *hPtr, *hPtr2;
1666: int new;
1667:
1668: if (argc < 2) {
1669: Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
1670: argv[0], " varName ?varName ...?\"", (char *) NULL);
1671: return TCL_ERROR;
1672: }
1673: if (iPtr->varFramePtr == NULL) {
1674: return TCL_OK;
1675: }
1676:
1677: for (argc--, argv++; argc > 0; argc--, argv++) {
1678: hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
1679: if (new) {
1680: gVarPtr = NewVar(0);
1681: gVarPtr->flags |= VAR_UNDEFINED;
1682: Tcl_SetHashValue(hPtr, gVarPtr);
1683: } else {
1684: gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
1685: }
1686: hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
1687: if (!new) {
1688: Var *varPtr;
1689: varPtr = (Var *) Tcl_GetHashValue(hPtr2);
1690: if (varPtr->flags & VAR_UPVAR) {
1691: continue;
1692: } else {
1693: Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
1694: "\" already exists", (char *) NULL);
1695: return TCL_ERROR;
1696: }
1697: }
1698: varPtr = NewVar(0);
1699: varPtr->flags |= VAR_UPVAR;
1700: varPtr->value.upvarPtr = hPtr;
1701: gVarPtr->upvarUses++;
1702: Tcl_SetHashValue(hPtr2, varPtr);
1703: }
1704: return TCL_OK;
1705: }
1706:
1707: /*
1708: *----------------------------------------------------------------------
1709: *
1710: * Tcl_UpvarCmd --
1711: *
1712: * This procedure is invoked to process the "upvar" Tcl command.
1713: * See the user documentation for details on what it does.
1714: *
1715: * Results:
1716: * A standard Tcl result value.
1717: *
1718: * Side effects:
1719: * See the user documentation.
1720: *
1721: *----------------------------------------------------------------------
1722: */
1723:
1724: /* ARGSUSED */
1725: int
1726: Tcl_UpvarCmd(dummy, interp, argc, argv)
1727: ClientData dummy; /* Not used. */
1728: Tcl_Interp *interp; /* Current interpreter. */
1729: int argc; /* Number of arguments. */
1730: char **argv; /* Argument strings. */
1731: {
1732: register Interp *iPtr = (Interp *) interp;
1733: int result;
1734: CallFrame *framePtr;
1735: Var *varPtr = NULL;
1736: Tcl_HashTable *upVarTablePtr;
1737: Tcl_HashEntry *hPtr, *hPtr2;
1738: int new;
1739: Var *upVarPtr;
1740:
1741: if (argc < 3) {
1742: upvarSyntax:
1743: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1744: " ?level? otherVar localVar ?otherVar localVar ...?\"",
1745: (char *) NULL);
1746: return TCL_ERROR;
1747: }
1748:
1749: /*
1750: * Find the hash table containing the variable being referenced.
1751: */
1752:
1753: result = TclGetFrame(interp, argv[1], &framePtr);
1754: if (result == -1) {
1755: return TCL_ERROR;
1756: }
1757: argc -= result+1;
1758: argv += result+1;
1759: if (framePtr == NULL) {
1760: upVarTablePtr = &iPtr->globalTable;
1761: } else {
1762: upVarTablePtr = &framePtr->varTable;
1763: }
1764:
1765: if ((argc & 1) != 0) {
1766: goto upvarSyntax;
1767: }
1768:
1769: /*
1770: * Iterate over all the pairs of (local variable, other variable)
1771: * names. For each pair, create a hash table entry in the upper
1772: * context (if the name wasn't there already), then associate it
1773: * with a new local variable.
1774: */
1775:
1776: while (argc > 0) {
1777: hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
1778: if (new) {
1779: upVarPtr = NewVar(0);
1780: upVarPtr->flags |= VAR_UNDEFINED;
1781: Tcl_SetHashValue(hPtr, upVarPtr);
1782: } else {
1783: upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
1784: if (upVarPtr->flags & VAR_UPVAR) {
1785: hPtr = upVarPtr->value.upvarPtr;
1786: upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
1787: }
1788: }
1789:
1790: hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
1791: argv[1], &new);
1792: if (!new) {
1793: Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
1794: "\" already exists", (char *) NULL);
1795: return TCL_ERROR;
1796: }
1797: varPtr = NewVar(0);
1798: varPtr->flags |= VAR_UPVAR;
1799: varPtr->value.upvarPtr = hPtr;
1800: upVarPtr->upvarUses++;
1801: Tcl_SetHashValue(hPtr2, varPtr);
1802:
1803: argc -= 2;
1804: argv += 2;
1805: }
1806: return TCL_OK;
1807: }
1808:
1809: /*
1810: *----------------------------------------------------------------------
1811: *
1812: * TclDeleteVars --
1813: *
1814: * This procedure is called to recycle all the storage space
1815: * associated with a table of variables. For this procedure
1816: * to work correctly, it must not be possible for any of the
1817: * variable in the table to be accessed from Tcl commands
1818: * (e.g. from trace procedures).
1819: *
1820: * Results:
1821: * None.
1822: *
1823: * Side effects:
1824: * Variables are deleted and trace procedures are invoked, if
1825: * any are declared.
1826: *
1827: *----------------------------------------------------------------------
1828: */
1829:
1830: void
1831: TclDeleteVars(iPtr, tablePtr)
1832: Interp *iPtr; /* Interpreter to which variables belong. */
1833: Tcl_HashTable *tablePtr; /* Hash table containing variables to
1834: * delete. */
1835: {
1836: Tcl_HashSearch search;
1837: Tcl_HashEntry *hPtr;
1838: register Var *varPtr;
1839: int flags, globalFlag;
1840:
1841: flags = TCL_TRACE_UNSETS;
1842: if (tablePtr == &iPtr->globalTable) {
1843: flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
1844: }
1845: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
1846: hPtr = Tcl_NextHashEntry(&search)) {
1847: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1848:
1849: /*
1850: * For global/upvar variables referenced in procedures, free up the
1851: * local space and then decrement the reference count on the
1852: * variable referred to. If there are no more references to the
1853: * global/upvar and it is undefined and has no traces set, then
1854: * follow on and delete the referenced variable too.
1855: */
1856:
1857: globalFlag = 0;
1858: if (varPtr->flags & VAR_UPVAR) {
1859: hPtr = varPtr->value.upvarPtr;
1860: ckfree((char *) varPtr);
1861: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1862: varPtr->upvarUses--;
1863: if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
1864: || (varPtr->tracePtr != NULL)) {
1865: continue;
1866: }
1867: globalFlag = TCL_GLOBAL_ONLY;
1868: }
1869:
1870: /*
1871: * Invoke traces on the variable that is being deleted, then
1872: * free up the variable's space (no need to free the hash entry
1873: * here, unless we're dealing with a global variable: the
1874: * hash entries will be deleted automatically when the whole
1875: * table is deleted).
1876: */
1877:
1878: if (varPtr->tracePtr != NULL) {
1879: (void) CallTraces(iPtr, (Var *) NULL, hPtr,
1880: Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
1881: flags | globalFlag);
1882: while (varPtr->tracePtr != NULL) {
1883: VarTrace *tracePtr = varPtr->tracePtr;
1884: varPtr->tracePtr = tracePtr->nextPtr;
1885: ckfree((char *) tracePtr);
1886: }
1887: }
1888: if (varPtr->flags & VAR_ARRAY) {
1889: DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
1890: flags | globalFlag);
1891: }
1892: if (globalFlag) {
1893: Tcl_DeleteHashEntry(hPtr);
1894: }
1895: ckfree((char *) varPtr);
1896: }
1897: Tcl_DeleteHashTable(tablePtr);
1898: }
1899:
1900: /*
1901: *----------------------------------------------------------------------
1902: *
1903: * CallTraces --
1904: *
1905: * This procedure is invoked to find and invoke relevant
1906: * trace procedures associated with a particular operation on
1907: * a variable. This procedure invokes traces both on the
1908: * variable and on its containing array (where relevant).
1909: *
1910: * Results:
1911: * The return value is NULL if no trace procedures were invoked, or
1912: * if all the invoked trace procedures returned successfully.
1913: * The return value is non-zero if a trace procedure returned an
1914: * error (in this case no more trace procedures were invoked after
1915: * the error was returned). In this case the return value is a
1916: * pointer to a static string describing the error.
1917: *
1918: * Side effects:
1919: * Almost anything can happen, depending on trace; this procedure
1920: * itself doesn't have any side effects.
1921: *
1922: *----------------------------------------------------------------------
1923: */
1924:
1925: static char *
1926: CallTraces(iPtr, arrayPtr, hPtr, name1, name2, flags)
1927: Interp *iPtr; /* Interpreter containing variable. */
1928: register Var *arrayPtr; /* Pointer to array variable that
1929: * contains the variable, or NULL if
1930: * the variable isn't an element of an
1931: * array. */
1932: Tcl_HashEntry *hPtr; /* Hash table entry corresponding to
1933: * variable whose traces are to be
1934: * invoked. */
1935: char *name1, *name2; /* Variable's two-part name. */
1936: int flags; /* Flags to pass to trace procedures:
1937: * indicates what's happening to
1938: * variable, plus other stuff like
1939: * TCL_GLOBAL_ONLY and
1940: * TCL_INTERP_DESTROYED. */
1941: {
1942: Var *varPtr;
1943: register VarTrace *tracePtr;
1944: ActiveVarTrace active;
1945: char *result;
1946: int savedArrayFlags = 0; /* (Initialization not needed except
1947: * to prevent compiler warning) */
1948:
1949: /*
1950: * If there are already similar trace procedures active for the
1951: * variable, don't call them again.
1952: */
1953:
1954: varPtr = (Var *) Tcl_GetHashValue(hPtr);
1955: if (varPtr->flags & VAR_TRACE_ACTIVE) {
1956: return NULL;
1957: }
1958: varPtr->flags |= VAR_TRACE_ACTIVE;
1959:
1960: /*
1961: * Invoke traces on the array containing the variable, if relevant.
1962: */
1963:
1964: result = NULL;
1965: active.nextPtr = iPtr->activeTracePtr;
1966: iPtr->activeTracePtr = &active;
1967: if (arrayPtr != NULL) {
1968: savedArrayFlags = arrayPtr->flags;
1969: arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
1970: for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
1971: tracePtr = active.nextTracePtr) {
1972: active.nextTracePtr = tracePtr->nextPtr;
1973: if (!(tracePtr->flags & flags)) {
1974: continue;
1975: }
1976: result = (*tracePtr->traceProc)(tracePtr->clientData,
1977: (Tcl_Interp *) iPtr, name1, name2, flags);
1978: if (result != NULL) {
1979: if (flags & TCL_TRACE_UNSETS) {
1980: result = NULL;
1981: } else {
1982: goto done;
1983: }
1984: }
1985: }
1986: }
1987:
1988: /*
1989: * Invoke traces on the variable itself.
1990: */
1991:
1992: if (flags & TCL_TRACE_UNSETS) {
1993: flags |= TCL_TRACE_DESTROYED;
1994: }
1995: for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
1996: tracePtr = active.nextTracePtr) {
1997: active.nextTracePtr = tracePtr->nextPtr;
1998: if (!(tracePtr->flags & flags)) {
1999: continue;
2000: }
2001: result = (*tracePtr->traceProc)(tracePtr->clientData,
2002: (Tcl_Interp *) iPtr, name1, name2, flags);
2003: if (result != NULL) {
2004: if (flags & TCL_TRACE_UNSETS) {
2005: result = NULL;
2006: } else {
2007: goto done;
2008: }
2009: }
2010: }
2011:
2012: /*
2013: * Restore the variable's flags, remove the record of our active
2014: * traces, and then return. Remember that the variable could have
2015: * been re-allocated during the traces, but its hash entry won't
2016: * change.
2017: */
2018:
2019: done:
2020: if (arrayPtr != NULL) {
2021: arrayPtr->flags = savedArrayFlags;
2022: }
2023: varPtr = (Var *) Tcl_GetHashValue(hPtr);
2024: varPtr->flags &= ~VAR_TRACE_ACTIVE;
2025: iPtr->activeTracePtr = active.nextPtr;
2026: return result;
2027: }
2028:
2029: /*
2030: *----------------------------------------------------------------------
2031: *
2032: * NewVar --
2033: *
2034: * Create a new variable with a given initial value.
2035: *
2036: * Results:
2037: * The return value is a pointer to the new variable structure.
2038: * The variable will not be part of any hash table yet, and its
2039: * upvarUses count is initialized to 0. Its initial value will
2040: * be empty, but "space" bytes will be available in the value
2041: * area.
2042: *
2043: * Side effects:
2044: * Storage gets allocated.
2045: *
2046: *----------------------------------------------------------------------
2047: */
2048:
2049: static Var *
2050: NewVar(space)
2051: int space; /* Minimum amount of space to allocate
2052: * for variable's value. */
2053: {
2054: int extra;
2055: register Var *varPtr;
2056:
2057: extra = space - sizeof(varPtr->value);
2058: if (extra < 0) {
2059: extra = 0;
2060: space = sizeof(varPtr->value);
2061: }
2062: varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
2063: varPtr->valueLength = 0;
2064: varPtr->valueSpace = space;
2065: varPtr->upvarUses = 0;
2066: varPtr->tracePtr = NULL;
2067: varPtr->searchPtr = NULL;
2068: varPtr->flags = 0;
2069: varPtr->value.string[0] = 0;
2070: return varPtr;
2071: }
2072:
2073: /*
2074: *----------------------------------------------------------------------
2075: *
2076: * ParseSearchId --
2077: *
2078: * This procedure translates from a string to a pointer to an
2079: * active array search (if there is one that matches the string).
2080: *
2081: * Results:
2082: * The return value is a pointer to the array search indicated
2083: * by string, or NULL if there isn't one. If NULL is returned,
2084: * interp->result contains an error message.
2085: *
2086: * Side effects:
2087: * None.
2088: *
2089: *----------------------------------------------------------------------
2090: */
2091:
2092: static ArraySearch *
2093: ParseSearchId(interp, varPtr, varName, string)
2094: Tcl_Interp *interp; /* Interpreter containing variable. */
2095: Var *varPtr; /* Array variable search is for. */
2096: char *varName; /* Name of array variable that search is
2097: * supposed to be for. */
2098: char *string; /* String containing id of search. Must have
2099: * form "search-num-var" where "num" is a
2100: * decimal number and "var" is a variable
2101: * name. */
2102: {
2103: char *end;
2104: int id;
2105: ArraySearch *searchPtr;
2106:
2107: /*
2108: * Parse the id into the three parts separated by dashes.
2109: */
2110:
2111: if ((string[0] != 's') || (string[1] != '-')) {
2112: syntax:
2113: Tcl_AppendResult(interp, "illegal search identifier \"", string,
2114: "\"", (char *) NULL);
2115: return NULL;
2116: }
2117: id = strtoul(string+2, &end, 10);
2118: if ((end == (string+2)) || (*end != '-')) {
2119: goto syntax;
2120: }
2121: if (strcmp(end+1, varName) != 0) {
2122: Tcl_AppendResult(interp, "search identifier \"", string,
2123: "\" isn't for variable \"", varName, "\"", (char *) NULL);
2124: return NULL;
2125: }
2126:
2127: /*
2128: * Search through the list of active searches on the interpreter
2129: * to see if the desired one exists.
2130: */
2131:
2132: for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
2133: searchPtr = searchPtr->nextPtr) {
2134: if (searchPtr->id == id) {
2135: return searchPtr;
2136: }
2137: }
2138: Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
2139: (char *) NULL);
2140: return NULL;
2141: }
2142:
2143: /*
2144: *----------------------------------------------------------------------
2145: *
2146: * DeleteSearches --
2147: *
2148: * This procedure is called to free up all of the searches
2149: * associated with an array variable.
2150: *
2151: * Results:
2152: * None.
2153: *
2154: * Side effects:
2155: * Memory is released to the storage allocator.
2156: *
2157: *----------------------------------------------------------------------
2158: */
2159:
2160: static void
2161: DeleteSearches(arrayVarPtr)
2162: register Var *arrayVarPtr; /* Variable whose searches are
2163: * to be deleted. */
2164: {
2165: ArraySearch *searchPtr;
2166:
2167: while (arrayVarPtr->searchPtr != NULL) {
2168: searchPtr = arrayVarPtr->searchPtr;
2169: arrayVarPtr->searchPtr = searchPtr->nextPtr;
2170: ckfree((char *) searchPtr);
2171: }
2172: }
2173:
2174: /*
2175: *----------------------------------------------------------------------
2176: *
2177: * DeleteArray --
2178: *
2179: * This procedure is called to free up everything in an array
2180: * variable. It's the caller's responsibility to make sure
2181: * that the array is no longer accessible before this procedure
2182: * is called.
2183: *
2184: * Results:
2185: * None.
2186: *
2187: * Side effects:
2188: * All storage associated with varPtr's array elements is deleted
2189: * (including the hash table). Any delete trace procedures for
2190: * array elements are invoked.
2191: *
2192: *----------------------------------------------------------------------
2193: */
2194:
2195: static void
2196: DeleteArray(iPtr, arrayName, varPtr, flags)
2197: Interp *iPtr; /* Interpreter containing array. */
2198: char *arrayName; /* Name of array (used for trace
2199: * callbacks). */
2200: Var *varPtr; /* Pointer to variable structure. */
2201: int flags; /* Flags to pass to CallTraces:
2202: * TCL_TRACE_UNSETS and sometimes
2203: * TCL_INTERP_DESTROYED and/or
2204: * TCL_GLOBAL_ONLY. */
2205: {
2206: Tcl_HashSearch search;
2207: register Tcl_HashEntry *hPtr;
2208: register Var *elPtr;
2209:
2210: DeleteSearches(varPtr);
2211: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
2212: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
2213: elPtr = (Var *) Tcl_GetHashValue(hPtr);
2214: if (elPtr->tracePtr != NULL) {
2215: (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
2216: Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
2217: while (elPtr->tracePtr != NULL) {
2218: VarTrace *tracePtr = elPtr->tracePtr;
2219: elPtr->tracePtr = tracePtr->nextPtr;
2220: ckfree((char *) tracePtr);
2221: }
2222: }
2223: if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
2224: panic("DeleteArray found searches on array alement!");
2225: }
2226: ckfree((char *) elPtr);
2227: }
2228: Tcl_DeleteHashTable(varPtr->value.tablePtr);
2229: ckfree((char *) varPtr->value.tablePtr);
2230: }
2231:
2232: /*
2233: *----------------------------------------------------------------------
2234: *
2235: * VarErrMsg --
2236: *
2237: * Generate a reasonable error message describing why a variable
2238: * operation failed.
2239: *
2240: * Results:
2241: * None.
2242: *
2243: * Side effects:
2244: * Interp->result is reset to hold a message identifying the
2245: * variable given by name1 and name2 and describing why the
2246: * variable operation failed.
2247: *
2248: *----------------------------------------------------------------------
2249: */
2250:
2251: static void
2252: VarErrMsg(interp, name1, name2, operation, reason)
2253: Tcl_Interp *interp; /* Interpreter in which to record message. */
2254: char *name1, *name2; /* Variable's two-part name. */
2255: char *operation; /* String describing operation that failed,
2256: * e.g. "read", "set", or "unset". */
2257: char *reason; /* String describing why operation failed. */
2258: {
2259: Tcl_ResetResult(interp);
2260: Tcl_AppendResult(interp, "can't ", operation, " \"", name1, (char *) NULL);
2261: if (name2 != NULL) {
2262: Tcl_AppendResult(interp, "(", name2, ")", (char *) NULL);
2263: }
2264: Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
2265: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.