1#include "xotclInt.h"
2#define TclDecrRefCount Tcl_DecrRefCount
3/*
4 * the following functions are copied from Tcl 8.4.19.
5 * We need just TclDeleteVars, but TclDeleteVars calls
6 * CallVarTraces() and DeleteArray();
7 */
8static void
9DisposeTraceResult(flags, result)
10    int flags;			/* Indicates type of result to determine
11				 * proper disposal method */
12    char *result;		/* The result returned from a trace
13				 * procedure to be disposed */
14{
15    if (flags & TCL_TRACE_RESULT_DYNAMIC) {
16	ckfree(result);
17    } else if (flags & TCL_TRACE_RESULT_OBJECT) {
18	Tcl_DecrRefCount((Tcl_Obj *) result);
19    }
20}
21
22static void
23VarErrMsg(interp, part1, part2, operation, reason)
24    Tcl_Interp *interp;         /* Interpreter in which to record message. */
25    CONST char *part1;
26    CONST char *part2;		/* Variable's two-part name. */
27    CONST char *operation;      /* String describing operation that failed,
28                                 * e.g. "read", "set", or "unset". */
29    CONST char *reason;         /* String describing why operation failed. */
30{
31    Tcl_ResetResult(interp);
32    Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
33	    (char *) NULL);
34    if (part2 != NULL) {
35        Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
36    }
37    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
38}
39
40static int
41CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
42    Interp *iPtr;		/* Interpreter containing variable. */
43    register Var *arrayPtr;	/* Pointer to array variable that contains
44				 * the variable, or NULL if the variable
45				 * isn't an element of an array. */
46    Var *varPtr;		/* Variable whose traces are to be
47				 * invoked. */
48    CONST char *part1;
49    CONST char *part2;		/* Variable's two-part name. */
50    int flags;			/* Flags passed to trace procedures:
51				 * indicates what's happening to variable,
52				 * plus other stuff like TCL_GLOBAL_ONLY,
53				 * or TCL_NAMESPACE_ONLY. */
54    CONST int leaveErrMsg;	/* If true, and one of the traces indicates an
55				 * error, then leave an error message and stack
56				 * trace information in *iPTr. */
57{
58    register VarTrace *tracePtr;
59    ActiveVarTrace active;
60    char *result;
61    CONST char *openParen, *p;
62    Tcl_DString nameCopy;
63    int copiedName;
64    int code = TCL_OK;
65    int disposeFlags = 0;
66    int saveErrFlags = iPtr->flags
67	    & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
68
69    /*
70     * If there are already similar trace procedures active for the
71     * variable, don't call them again.
72     */
73
74    if (varPtr->flags & VAR_TRACE_ACTIVE) {
75	return code;
76    }
77    varPtr->flags |= VAR_TRACE_ACTIVE;
78    varPtr->refCount++;
79    if (arrayPtr != NULL) {
80	arrayPtr->refCount++;
81    }
82
83    /*
84     * If the variable name hasn't been parsed into array name and
85     * element, do it here.  If there really is an array element,
86     * make a copy of the original name so that NULLs can be
87     * inserted into it to separate the names (can't modify the name
88     * string in place, because the string might get used by the
89     * callbacks we invoke).
90     */
91
92    copiedName = 0;
93    if (part2 == NULL) {
94	for (p = part1; *p ; p++) {
95	    if (*p == '(') {
96		openParen = p;
97		do {
98		    p++;
99		} while (*p != '\0');
100		p--;
101		if (*p == ')') {
102		    int offset = (openParen - part1);
103		    char *newPart1;
104		    Tcl_DStringInit(&nameCopy);
105		    Tcl_DStringAppend(&nameCopy, part1, (p-part1));
106		    newPart1 = Tcl_DStringValue(&nameCopy);
107		    newPart1[offset] = 0;
108		    part1 = newPart1;
109		    part2 = newPart1 + offset + 1;
110		    copiedName = 1;
111		}
112		break;
113	    }
114	}
115    }
116
117    /*
118     * Invoke traces on the array containing the variable, if relevant.
119     */
120
121    result = NULL;
122    active.nextPtr = iPtr->activeVarTracePtr;
123    iPtr->activeVarTracePtr = &active;
124    Tcl_Preserve((ClientData) iPtr);
125    if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
126	active.varPtr = arrayPtr;
127	for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
128	     tracePtr = active.nextTracePtr) {
129	    active.nextTracePtr = tracePtr->nextPtr;
130	    if (!(tracePtr->flags & flags)) {
131		continue;
132	    }
133	    Tcl_Preserve((ClientData) tracePtr);
134	    if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
135		flags |= TCL_INTERP_DESTROYED;
136	    }
137	    result = (*tracePtr->traceProc)(tracePtr->clientData,
138		    (Tcl_Interp *) iPtr, part1, part2, flags);
139	    if (result != NULL) {
140		if (flags & TCL_TRACE_UNSETS) {
141		    /* Ignore errors in unset traces */
142		    DisposeTraceResult(tracePtr->flags, result);
143		} else {
144	            disposeFlags = tracePtr->flags;
145		    code = TCL_ERROR;
146		}
147	    }
148	    Tcl_Release((ClientData) tracePtr);
149	    if (code == TCL_ERROR) {
150		goto done;
151	    }
152	}
153    }
154
155    /*
156     * Invoke traces on the variable itself.
157     */
158
159    if (flags & TCL_TRACE_UNSETS) {
160	flags |= TCL_TRACE_DESTROYED;
161    }
162    active.varPtr = varPtr;
163    for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
164	 tracePtr = active.nextTracePtr) {
165	active.nextTracePtr = tracePtr->nextPtr;
166	if (!(tracePtr->flags & flags)) {
167	    continue;
168	}
169	Tcl_Preserve((ClientData) tracePtr);
170	if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
171	    flags |= TCL_INTERP_DESTROYED;
172	}
173	result = (*tracePtr->traceProc)(tracePtr->clientData,
174		(Tcl_Interp *) iPtr, part1, part2, flags);
175	if (result != NULL) {
176	    if (flags & TCL_TRACE_UNSETS) {
177		/* Ignore errors in unset traces */
178		DisposeTraceResult(tracePtr->flags, result);
179	    } else {
180		disposeFlags = tracePtr->flags;
181		code = TCL_ERROR;
182	    }
183	}
184	Tcl_Release((ClientData) tracePtr);
185	if (code == TCL_ERROR) {
186	    goto done;
187	}
188    }
189
190    /*
191     * Restore the variable's flags, remove the record of our active
192     * traces, and then return.
193     */
194
195    done:
196    if (code == TCL_OK) {
197	iPtr->flags |= saveErrFlags;
198    }
199    if (code == TCL_ERROR) {
200	if (leaveErrMsg) {
201	    CONST char *type = "";
202	    switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
203		case TCL_TRACE_READS: {
204		    type = "read";
205		    break;
206		}
207		case TCL_TRACE_WRITES: {
208		    type = "set";
209		    break;
210		}
211		case TCL_TRACE_ARRAY: {
212		    type = "trace array";
213		    break;
214		}
215	    }
216	    if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
217		VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type,
218			Tcl_GetString((Tcl_Obj *) result));
219	    } else {
220		VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result);
221	    }
222	}
223	DisposeTraceResult(disposeFlags,result);
224    }
225
226    if (arrayPtr != NULL) {
227	arrayPtr->refCount--;
228    }
229    if (copiedName) {
230	Tcl_DStringFree(&nameCopy);
231    }
232    varPtr->flags &= ~VAR_TRACE_ACTIVE;
233    varPtr->refCount--;
234    iPtr->activeVarTracePtr = active.nextPtr;
235    Tcl_Release((ClientData) iPtr);
236
237    return code;
238}
239static void
240DeleteSearches(arrayVarPtr)
241    register Var *arrayVarPtr;		/* Variable whose searches are
242					 * to be deleted. */
243{
244    ArraySearch *searchPtr;
245
246    while (arrayVarPtr->searchPtr != NULL) {
247	searchPtr = arrayVarPtr->searchPtr;
248	arrayVarPtr->searchPtr = searchPtr->nextPtr;
249	ckfree((char *) searchPtr);
250    }
251}
252
253static void
254DeleteArray(iPtr, arrayName, varPtr, flags)
255    Interp *iPtr;			/* Interpreter containing array. */
256    CONST char *arrayName;	        /* Name of array (used for trace
257					 * callbacks). */
258    Var *varPtr;			/* Pointer to variable structure. */
259    int flags;				/* Flags to pass to CallVarTraces:
260					 * TCL_TRACE_UNSETS and sometimes
261					 * TCL_NAMESPACE_ONLY, or
262					 * TCL_GLOBAL_ONLY. */
263{
264    Tcl_HashSearch search;
265    register Tcl_HashEntry *hPtr;
266    register Var *elPtr;
267    ActiveVarTrace *activePtr;
268    Tcl_Obj *objPtr;
269
270    DeleteSearches(varPtr);
271    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
272	 hPtr != NULL;  hPtr = Tcl_NextHashEntry(&search)) {
273	elPtr = (Var *) Tcl_GetHashValue(hPtr);
274	if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
275	    objPtr = elPtr->value.objPtr;
276	    TclDecrRefCount(objPtr);
277	    elPtr->value.objPtr = NULL;
278	}
279	elPtr->hPtr = NULL;
280	if (elPtr->tracePtr != NULL) {
281	    elPtr->flags &= ~VAR_TRACE_ACTIVE;
282	    CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
283		    Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
284		    /* leaveErrMsg */ 0);
285	    while (elPtr->tracePtr != NULL) {
286		VarTrace *tracePtr = elPtr->tracePtr;
287		elPtr->tracePtr = tracePtr->nextPtr;
288		Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
289	    }
290	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
291		 activePtr = activePtr->nextPtr) {
292		if (activePtr->varPtr == elPtr) {
293		    activePtr->nextTracePtr = NULL;
294		}
295	    }
296	}
297	TclSetVarUndefined(elPtr);
298	TclSetVarScalar(elPtr);
299
300	/*
301	 * Even though array elements are not supposed to be namespace
302	 * variables, some combinations of [upvar] and [variable] may
303	 * create such beasts - see [Bug 604239]. This is necessary to
304	 * avoid leaking the corresponding Var struct, and is otherwise
305	 * harmless.
306	 */
307
308	if (elPtr->flags & VAR_NAMESPACE_VAR) {
309	    elPtr->flags &= ~VAR_NAMESPACE_VAR;
310	    elPtr->refCount--;
311	}
312	if (elPtr->refCount == 0) {
313	    ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */
314	}
315    }
316    Tcl_DeleteHashTable(varPtr->value.tablePtr);
317    ckfree((char *) varPtr->value.tablePtr);
318}
319
320void
321TclDeleteVars84(iPtr, tablePtr)
322    Interp *iPtr;		/* Interpreter to which variables belong. */
323    Tcl_HashTable *tablePtr;	/* Hash table containing variables to
324				 * delete. */
325{
326    Tcl_Interp *interp = (Tcl_Interp *) iPtr;
327    Tcl_HashSearch search;
328    Tcl_HashEntry *hPtr;
329    register Var *varPtr;
330    Var *linkPtr;
331    int flags;
332    ActiveVarTrace *activePtr;
333    Tcl_Obj *objPtr;
334    Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
335
336    /*
337     * Determine what flags to pass to the trace callback procedures.
338     */
339
340    flags = TCL_TRACE_UNSETS;
341    if (tablePtr == &iPtr->globalNsPtr->varTable) {
342	flags |= TCL_GLOBAL_ONLY;
343    } else if (tablePtr == &currNsPtr->varTable) {
344	flags |= TCL_NAMESPACE_ONLY;
345    }
346
347    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);  hPtr != NULL;
348	 hPtr = Tcl_NextHashEntry(&search)) {
349	varPtr = (Var *) Tcl_GetHashValue(hPtr);
350
351	/*
352	 * For global/upvar variables referenced in procedures, decrement
353	 * the reference count on the variable referred to, and free
354	 * the referenced variable if it's no longer needed. Don't delete
355	 * the hash entry for the other variable if it's in the same table
356	 * as us: this will happen automatically later on.
357	 */
358	if (TclIsVarLink(varPtr)) {
359	    linkPtr = varPtr->value.linkPtr;
360	    linkPtr->refCount--;
361	    if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
362		    && (linkPtr->tracePtr == NULL)
363		    && (linkPtr->flags & VAR_IN_HASHTABLE)) {
364		if (linkPtr->hPtr == NULL) {
365		    ckfree((char *) linkPtr);
366		} else if (linkPtr->hPtr->tablePtr != tablePtr) {
367		    Tcl_DeleteHashEntry(linkPtr->hPtr);
368		    ckfree((char *) linkPtr);
369		}
370	    }
371	}
372
373	/*
374	 * Invoke traces on the variable that is being deleted, then
375	 * free up the variable's space (no need to free the hash entry
376	 * here, unless we're dealing with a global variable: the
377	 * hash entries will be deleted automatically when the whole
378	 * table is deleted). Note that we give CallVarTraces the variable's
379	 * fully-qualified name so that any called trace procedures can
380	 * refer to these variables being deleted.
381	 */
382
383	if (varPtr->tracePtr != NULL) {
384	    objPtr = Tcl_NewObj();
385	    Tcl_IncrRefCount(objPtr); /* until done with traces */
386	    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
387	    CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
388		    NULL, flags, /* leaveErrMsg */ 0);
389	    Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
390
391	    while (varPtr->tracePtr != NULL) {
392		VarTrace *tracePtr = varPtr->tracePtr;
393		varPtr->tracePtr = tracePtr->nextPtr;
394		Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
395	    }
396	    for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
397		 activePtr = activePtr->nextPtr) {
398		if (activePtr->varPtr == varPtr) {
399		    activePtr->nextTracePtr = NULL;
400		}
401	    }
402	}
403
404	if (TclIsVarArray(varPtr)) {
405	    DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
406	            flags);
407	    varPtr->value.tablePtr = NULL;
408	}
409
410	if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) {
411	    objPtr = varPtr->value.objPtr;
412	    TclDecrRefCount(objPtr);
413	    varPtr->value.objPtr = NULL;
414	}
415
416	varPtr->hPtr = NULL;
417	varPtr->tracePtr = NULL;
418	TclSetVarUndefined(varPtr);
419	TclSetVarScalar(varPtr);
420
421	/*
422	 * If the variable was a namespace variable, decrement its
423	 * reference count. We are in the process of destroying its
424	 * namespace so that namespace will no longer "refer" to the
425	 * variable.
426	 */
427
428	if (varPtr->flags & VAR_NAMESPACE_VAR) {
429	    varPtr->flags &= ~VAR_NAMESPACE_VAR;
430	    varPtr->refCount--;
431	}
432
433	/*
434	 * Recycle the variable's memory space if there aren't any upvar's
435	 * pointing to it. If there are upvars to this variable, then the
436	 * variable will get freed when the last upvar goes away.
437	 */
438
439	if (varPtr->refCount == 0) {
440	    ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */
441	}
442    }
443    Tcl_DeleteHashTable(tablePtr);
444
445}
446