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