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