]> git.zerfleddert.de Git - micropolis/blame - src/tcl/tclvar.c
fix colors on BGR displays
[micropolis] / src / tcl / tclvar.c
CommitLineData
6a5fa4e0
MG
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
22static 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
32static char *noSuchVar = "no such variable";
33static char *isArray = "variable is array";
34static char *needArray = "variable isn't array";
35static char *noSuchElement = "no such element in array";
36static char *traceActive = "trace is active on variable";
37
38/*
39 * Forward references to procedures defined later in this file:
40 */
41
42static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
43 Tcl_HashEntry *hPtr, char *name1, char *name2,
44 int flags));
45static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
46static void DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
47 Var *varPtr, int flags));
48static Var * NewVar _ANSI_ARGS_((int space));
49static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
50 Var *varPtr, char *varName, char *string));
51static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
52 char *name1, char *name2, char *operation,
53 char *reason));
54\f
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
78char *
79Tcl_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\f
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
145char *
146Tcl_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\f
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
264char *
265Tcl_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\f
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
332char *
333Tcl_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\f
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
526int
527Tcl_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\f
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
589int
590Tcl_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\f
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
749int
750Tcl_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\f
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
817int
818Tcl_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\f
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
928void
929Tcl_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\f
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
989void
990Tcl_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\f
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
1096ClientData
1097Tcl_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\f
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
1160ClientData
1161Tcl_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\f
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 */
1248int
1249Tcl_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\f
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 */
1298int
1299Tcl_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\f
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 */
1338int
1339Tcl_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\f
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 */
1384int
1385Tcl_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\f
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 */
1430int
1431Tcl_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\f
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 */
1656int
1657Tcl_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\f
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 */
1725int
1726Tcl_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\f
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
1830void
1831TclDeleteVars(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\f
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
1925static char *
1926CallTraces(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\f
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
2049static Var *
2050NewVar(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\f
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
2092static ArraySearch *
2093ParseSearchId(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\f
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
2160static void
2161DeleteSearches(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\f
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
2195static void
2196DeleteArray(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\f
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
2251static void
2252VarErrMsg(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}
Impressum, Datenschutz