diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 424 |
1 files changed, 272 insertions, 152 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index 12adf5e..ebf45f1 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -9,11 +9,12 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.1.2.3 1998/11/06 21:51:57 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.1.2.4 1999/02/10 23:31:20 stanton Exp $ */ #include "tclInt.h" @@ -28,7 +29,8 @@ static char *noSuchVar = "no such variable"; static char *isArray = "variable is array"; static char *needArray = "variable isn't array"; static char *noSuchElement = "no such element in array"; -static char *danglingUpvar = "upvar refers to element in deleted array"; +static char *danglingElement = "upvar refers to element in deleted array"; +static char *danglingVar = "upvar refers to variable in deleted namespace"; static char *badNamespace = "parent namespace doesn't exist"; static char *missingName = "missing variable name"; @@ -199,7 +201,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; } @@ -207,7 +209,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { result = (*resPtr->varResProc)(interp, part1, - (Tcl_Namespace *) cxtNsPtr, flags, &var); + (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; } @@ -238,27 +240,25 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(part1, "::") != NULL)) { + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(part1, "::") != NULL)) { char *tail; + /* + * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, + * or otherwise generate our own error! + */ var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, - flags); + flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { varPtr = (Var *) var; } if (varPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - Tcl_ResetResult(interp); - } if (createPart1) { /* var wasn't found so create it */ - result = TclGetNamespaceForQualName(interp, part1, - (Namespace *) NULL, flags, &varNsPtr, &dummy1Ptr, - &dummy2Ptr, &tail); - if (result != TCL_OK) { - goto done; - } + TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, + flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, badNamespace); @@ -308,7 +308,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (createPart1) { if (tablePtr == NULL) { tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); + ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); varFramePtr->varTablePtr = tablePtr; } @@ -337,7 +337,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, } } -lookupVarPart2: + lookupVarPart2: if (openParen != NULL) { *openParen = '('; openParen = NULL; @@ -374,10 +374,23 @@ lookupVarPart2: varPtr = NULL; goto done; } + + /* + * Make sure we are not resurrecting a namespace variable from a + * deleted namespace! + */ + if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, danglingVar); + } + varPtr = NULL; + goto done; + } + TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); varPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); } else if (!TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { @@ -498,17 +511,65 @@ Tcl_GetVar2(interp, part1, part2, flags) { Tcl_Obj *objPtr; - objPtr = Tcl_GetObjVar2(interp, part1, part2, flags); + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); if (objPtr == NULL) { return NULL; } return TclGetString(objPtr); } +/* + *---------------------------------------------------------------------- + * + * Tcl_ObjGetVar2 -- + * + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. + * + * Results: + * The return value points to the current object value of the variable + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. + * + * Side effects: + * The ref count for the returned object is _not_ incremented to + * reflect the returned reference; if you want to keep a reference to + * the object you must increment its ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be looked up. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_LEAVE_ERR_MSG, and + * TCL_PARSE_PART1 bits. */ +{ + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_GetVar2Ex(interp, part1, part2, flags); +} /* *---------------------------------------------------------------------- * - * Tcl_GetObjVar2 -- + * Tcl_GetVar2Ex -- * * Return the value of a Tcl variable as a Tcl object, given a * two-part name consisting of array name and element within array. @@ -529,7 +590,7 @@ Tcl_GetVar2(interp, part1, part2, flags) */ Tcl_Obj * -Tcl_GetObjVar2(interp, part1, part2, flags) +Tcl_GetVar2Ex(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ char *part1; /* Name of an array (if part2 is non-NULL) @@ -648,15 +709,16 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) int localCt = varFramePtr->procPtr->numCompiledLocals; if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with no compiled locals\n", - localIndex); - panic("TclGetIndexedScalar: no compiled locals in frame"); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", + localIndex, (unsigned int) varFramePtr); + panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame with %i locals\n", - localIndex, localCt); - panic("TclGetIndexedScalar: can't get local %i in frame with %i locals", - localIndex, localCt); + fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", + localIndex, (unsigned int) varFramePtr, localCt); + panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -769,15 +831,15 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -904,8 +966,7 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValueObj; if (objc == 2) { - varValueObj = Tcl_GetObjVar2(interp, TclGetString(objv[1]), NULL, - TCL_LEAVE_ERR_MSG); + varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } @@ -913,8 +974,8 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) return TCL_OK; } else if (objc == 3) { - varValueObj = Tcl_SetObjVar2(interp, TclGetString(objv[1]), NULL, - objv[2], TCL_LEAVE_ERR_MSG); + varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], + TCL_LEAVE_ERR_MSG); if (varValueObj == NULL) { return TCL_ERROR; } @@ -1008,20 +1069,16 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) { register Tcl_Obj *valuePtr; Tcl_Obj *varValuePtr; - int length; /* * Create an object holding the variable's new value and use - * Tcl_SetObjVar2 to actually set the variable. + * Tcl_SetVar2Ex to actually set the variable. */ - length = newValue ? strlen(newValue) : 0; - TclNewObj(valuePtr); - TclInitStringRep(valuePtr, newValue, length); + valuePtr = Tcl_NewStringObj(newValue, -1); Tcl_IncrRefCount(valuePtr); - varValuePtr = Tcl_SetObjVar2(interp, part1, part2, valuePtr, - flags); + varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); Tcl_DecrRefCount(valuePtr); /* done with the object */ if (varValuePtr == NULL) { @@ -1033,7 +1090,61 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) /* *---------------------------------------------------------------------- * - * Tcl_SetObjVar2 -- + * Tcl_ObjSetVar2 -- + * + * This function is the same as Tcl_SetVar2Ex below, except the + * variable names are passed in Tcl object instead of strings. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. + + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or + * TCL_PARSE_PART1. */ +{ + char *part1, *part2; + + part1 = Tcl_GetString(part1Ptr); + if (part2Ptr != NULL) { + part2 = Tcl_GetString(part2Ptr); + } else { + part2 = NULL; + } + + return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetVar2Ex -- * * Given a two-part variable name, which may refer either to a scalar * variable or an element of an array, change the value of the variable @@ -1057,7 +1168,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * and incremented for its new value. If the new value for the variable * is not the same one referenced by newValuePtr (perhaps as a result * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_SetObjVar2. newValuePtr's ref count is also left unchanged if + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if * we are appending it as a string value: that is, if "flags" includes * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. * @@ -1069,7 +1180,7 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) */ Tcl_Obj * -Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ char *part1; /* Name of an array (if part2 is non-NULL) @@ -1098,15 +1209,19 @@ Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, part1, part2, "set", danglingElement); + } else { + VarErrMsg(interp, part1, part2, "set", danglingVar); + } } return NULL; } @@ -1196,7 +1311,7 @@ Tcl_SetObjVar2(interp, part1, part2, newValuePtr, flags) neededBytes = Tcl_ScanElement(bytes, &listFlags); oldValuePtr = Tcl_NewObj(); oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); + ckalloc((unsigned) (neededBytes + 1)); oldValuePtr->length = Tcl_ConvertElement(bytes, oldValuePtr->bytes, listFlags); varPtr->value.objPtr = oldValuePtr; @@ -1323,15 +1438,15 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1351,15 +1466,19 @@ TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) /* * If the variable is in a hashtable and its hPtr field is NULL, then we - * have an upvar to an array element where the array was deleted, - * leaving the element dangling at the end of the upvar. Generate an - * error (allowing the variable to be reset would screw up our storage - * allocation and is meaningless anyway). + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). */ if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", danglingUpvar); + if (TclIsVarArrayElement(varPtr)) { + VarErrMsg(interp, varName, NULL, "set", danglingElement); + } else { + VarErrMsg(interp, varName, NULL, "set", danglingVar); + } } return NULL; } @@ -1504,15 +1623,15 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, if (compiledLocals == NULL) { fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); + (unsigned int) varFramePtr); } if ((localIndex < 0) || (localIndex >= localCt)) { fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); + localIndex, (unsigned int) varFramePtr, localCt); panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); + localIndex, (unsigned int) varFramePtr); } #endif /* TCL_COMPILE_DEBUG */ @@ -1532,13 +1651,32 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, } /* + * If the variable is in a hashtable and its hPtr field is NULL, then we + * may have an upvar to an array element where the array was deleted + * or an upvar to a namespace variable whose namespace was deleted. + * Generate an error (allowing the variable to be reset would screw up + * our storage allocation and is meaningless anyway). + */ + + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { + if (leaveErrorMsg) { + if (TclIsVarArrayElement(arrayPtr)) { + VarErrMsg(interp, arrayName, elem, "set", danglingElement); + } else { + VarErrMsg(interp, arrayName, elem, "set", danglingVar); + } + } + goto errorReturn; + } + + /* * Make sure we're dealing with an array. */ if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { TclSetVarArray(arrayPtr); arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); TclClearVarUndefined(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { @@ -1681,17 +1819,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ - char *part1 = TclGetString(part1Ptr); long i; int result; - char *index; - if (part2Ptr != NULL) { - index = TclGetString(part2Ptr); - } else { - index = NULL; - } - varValuePtr = Tcl_GetObjVar2(interp, part1, index, flags); + varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1723,7 +1854,7 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) * Store the variable's new value and run any write traces. */ - resultPtr = Tcl_SetObjVar2(interp, part1, index, varValuePtr, flags); + resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); if (resultPtr == NULL) { return NULL; } @@ -1772,7 +1903,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) int result; varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1806,7 +1937,7 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) */ resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -1859,7 +1990,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) int result; varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); + /*leaveErrorMsg*/ 1); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1893,8 +2024,8 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) */ resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); + varValuePtr, + /*leaveErrorMsg*/ 1); if (resultPtr == NULL) { return NULL; } @@ -2027,7 +2158,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -2045,7 +2176,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) dummyVarPtr = &dummyVar; if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); } if (TclIsVarScalar(dummyVarPtr) && (dummyVarPtr->value.objPtr != NULL)) { @@ -2055,9 +2186,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) } /* - * If the variable was a namespace variable, decrement its reference - * count. We are in the process of destroying its namespace so that - * namespace will no longer "refer" to the variable. + * If the variable was a namespace variable, decrement its reference count. */ if (varPtr->flags & VAR_NAMESPACE_VAR) { @@ -2179,8 +2308,8 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; @@ -2270,7 +2399,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; - prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { + prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { return; } @@ -2287,7 +2416,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) */ for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; } @@ -2490,23 +2619,21 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler * warning. */ - char *varName; int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - varName = TclGetString(objv[1]); if (objc == 2) { - varValuePtr = Tcl_GetObjVar2(interp, varName, NULL, TCL_LEAVE_ERR_MSG); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { for (i = 2; i < objc; i++) { - varValuePtr = Tcl_SetObjVar2(interp, varName, NULL, objv[i], - (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2544,16 +2671,15 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *varValuePtr, *newValuePtr; register List *listRepPtr; register Tcl_Obj **elemPtrs; - char *varName; int numElems, numRequired, createdNewObj, createVar, i, j; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - varName = TclGetString(objv[1]); if (objc == 2) { - newValuePtr = Tcl_GetObjVar2(interp, varName, NULL, TCL_LEAVE_ERR_MSG); + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + (TCL_LEAVE_ERR_MSG)); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2561,7 +2687,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) */ Tcl_Obj *nullObjPtr = Tcl_NewObj(); - newValuePtr = Tcl_SetObjVar2(interp, varName, NULL, + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ @@ -2570,7 +2696,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) } } else { /* - * We have arguments to append. We used to call Tcl_SetObjVar2 to + * We have arguments to append. We used to call Tcl_SetVar2 to * append each argument one at a time to ensure that traces were run * for each append step. We now append the arguments all at once * because it's faster. Note that a read trace and a write trace for @@ -2581,7 +2707,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_GetObjVar2(interp, varName, NULL, 0); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2589,7 +2715,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - char *p; + char *p, *varName; int nameBytes, i; varName = Tcl_GetStringFromObj(objv[1], &nameBytes); @@ -2635,7 +2761,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) if (numRequired > listRepPtr->maxElemCount) { int newMax = (2 * numRequired); Tcl_Obj **newElemPtrs = (Tcl_Obj **) - ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); + ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, (size_t) (numElems * sizeof(Tcl_Obj *))); @@ -2668,7 +2794,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_SetObjVar2(interp, varName, NULL, varValuePtr, + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { @@ -2721,8 +2847,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, ARRAY_STARTSEARCH}; static char *arrayOptions[] = {"anymore", "donesearch", "exists", - "get", "names", "nextelement", "set", "size", "startsearch", - (char *) NULL}; + "get", "names", "nextelement", "set", "size", "startsearch", + (char *) NULL}; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; @@ -2829,7 +2955,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr->nextPtr; } else { for (prevPtr = varPtr->searchPtr; ; - prevPtr = prevPtr->nextPtr) { + prevPtr = prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; @@ -2865,7 +2991,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = TclGetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -2883,8 +3009,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return result; } - valuePtr = Tcl_GetObjVar2(interp, - TclGetString(objv[2]), TclGetString(namePtr), + valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ @@ -2917,7 +3042,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) pattern = Tcl_GetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -2996,9 +3121,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } if (listLen > 0) { for (i = 0; i < listLen; i += 2) { - if (Tcl_SetObjVar2(interp, TclGetString(objv[2]), - TclGetString(elemPtrs[i]), elemPtrs[i+1], - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; break; } @@ -3058,7 +3182,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (!notArray) { for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { continue; @@ -3090,7 +3214,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, - (char *) NULL); + (char *) NULL); } searchPtr->varPtr = varPtr; searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, @@ -3149,7 +3273,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) Tcl_HashTable *tablePtr; Namespace *nsPtr, *altNsPtr, *dummyNsPtr; char *tail; - int new, result; + int new; /* * Find "other" in "framePtr". If not looking up other in just the @@ -3188,21 +3312,18 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) varFramePtr = iPtr->varFramePtr; if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(myName, "::") != NULL)) { - result = TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, - (Namespace *) NULL, (myFlags | TCL_LEAVE_ERR_MSG), - &nsPtr, &altNsPtr, &dummyNsPtr, &tail); - if (result != TCL_OK) { - return result; - } + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL)) { + TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, + (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail); + if (nsPtr == NULL) { nsPtr = altNsPtr; } if (nsPtr == NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": unknown namespace", (char *) NULL); + myName, "\": unknown namespace", (char *) NULL); return TCL_ERROR; } @@ -3295,11 +3416,11 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) } } else if (!TclIsVarUndefined(varPtr)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" already exists", (char *) NULL); + "\" already exists", (char *) NULL); return TCL_ERROR; } else if (varPtr->tracePtr != NULL) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); + "\" has traces: can't use for upvar", (char *) NULL); return TCL_ERROR; } } @@ -3606,7 +3727,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - char *varName, *tail; + char *varName, *tail, *cp; Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; @@ -3645,8 +3766,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_SetObjVar2(interp, TclGetString(objv[i]), - NULL, objv[i+1], + varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; @@ -3663,17 +3783,17 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) /* * varName might have a scope qualifier, but the name for the * local "link" variable must be the simple name at the tail. + * + * Locate tail in one pass: drop any prefix after two *or more* + * consecutive ":" characters). */ - for (tail = varName; *tail != '\0'; tail++) { - /* empty body */ - } - while ((tail > varName) - && ((*tail != ':') || (*(tail-1) != ':'))) { - tail--; - } - if (*tail == ':') { - tail++; + for (tail = cp = varName; *cp != '\0'; ) { + if (*cp++ == ':') { + while (*cp++ == ':') { + tail = cp; + } + } } /* @@ -3868,7 +3988,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); + + (openParen + 1 - part1); part2[-1] = 0; part1 = Tcl_DStringValue(&nameCopy); copiedName = 1; @@ -3889,7 +4009,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) arrayPtr->refCount++; active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -3915,7 +4035,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } active.varPtr = varPtr; for (tracePtr = varPtr->tracePtr; tracePtr != NULL; - tracePtr = active.nextTracePtr) { + tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { continue; @@ -4047,7 +4167,7 @@ ParseSearchId(interp, varPtr, varName, string) */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { + searchPtr = searchPtr->nextPtr) { if (searchPtr->id == id) { return searchPtr; } @@ -4137,7 +4257,7 @@ TclDeleteVars(iPtr, tablePtr) } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { varPtr = (Var *) Tcl_GetHashValue(hPtr); /* @@ -4187,7 +4307,7 @@ TclDeleteVars(iPtr, tablePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4311,7 +4431,7 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; } @@ -4381,7 +4501,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) DeleteSearches(varPtr); for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { elPtr = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; @@ -4399,7 +4519,7 @@ DeleteArray(iPtr, arrayName, varPtr, flags) ckfree((char *) tracePtr); } for (activePtr = iPtr->activeTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { + activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; } @@ -4493,7 +4613,7 @@ VarErrMsg(interp, part1, part2, operation, reason) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, - (char *) NULL); + (char *) NULL); if (part2 != NULL) { Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); } |