diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 815 |
1 files changed, 369 insertions, 446 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index 30e2f9b..7c8bb73 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -149,6 +149,7 @@ static const char *isArrayElement = */ typedef struct ArraySearch { + Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ @@ -188,8 +189,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static int SetArraySearchObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); +static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj); /* * Functions defined in this file that may be exported in the future for use @@ -202,14 +202,9 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; -static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; -static Tcl_UpdateStringProc UpdateParsedVarName; - -static Tcl_UpdateStringProc PanicOnUpdateVarName; -static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. @@ -228,30 +223,14 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName + FreeLocalVarName, DupLocalVarName, NULL, NULL }; static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, NULL, NULL }; -/* - * Type of Tcl_Objs used to speed up array searches. - * - * INTERNALREP DEFINITION: - * twoPtrValue.ptr1: searchIdNumber (cast to pointer) - * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) - * - * Note that the value stored in ptr2 is the offset into the string of the - * start of the variable name and not the address of the variable name itself, - * as this can be safely copied. - */ - -const Tcl_ObjType tclArraySearchType = { - "array search", - NULL, NULL, NULL, SetArraySearchObj -}; Var * TclVarHashCreateVar( @@ -522,17 +501,13 @@ TclObjLookupVarEx( * is set to NULL. */ { Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ - const char *part1; - int index, len1, len2; - int parsed = 0; - Tcl_Obj *objPtr; - const Tcl_ObjType *typePtr = part1Ptr->typePtr; const char *errMsg = NULL; - CallFrame *varFramePtr = iPtr->varFramePtr; - const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; - char *newPart2 = NULL; + int index, parsed = 0; + const Tcl_ObjType *typePtr = part1Ptr->typePtr; + *arrayPtrPtr = NULL; if (typePtr == &localVarNameType) { @@ -548,7 +523,7 @@ TclObjLookupVarEx( */ Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); + Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { @@ -579,13 +554,7 @@ TclObjLookupVarEx( } return NULL; } - part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; - if (newPart2) { - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } - } + part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; if (typePtr == &localVarNameType) { @@ -594,18 +563,23 @@ TclObjLookupVarEx( } parsed = 1; } - part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { + if (!parsed) { + /* * part1Ptr is possibly an unparsed array element. */ - register int i; + int len; + const char *part1 = TclGetStringFromObj(part1Ptr, &len); + + if (len > 1 && (part1[len - 1] == ')')) { + + const char *part2 = strchr(part1, '('); + + if (part2) { + Tcl_Obj *arrayPtr; - len2 = -1; - for (i = 0; i < len1; i++) { - if (*(part1 + i) == '(') { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -616,50 +590,19 @@ TclObjLookupVarEx( return NULL; } - /* - * part1Ptr points to an array element; first copy the element - * name to a new string part2. - */ + arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); + part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2); - part2 = part1 + i + 1; - len2 = len1 - i - 2; - len1 = i; - - newPart2 = ckalloc(len2 + 1); - memcpy(newPart2, part2, (unsigned) len2); - *(newPart2+len2) = '\0'; - part2 = newPart2; - part2Ptr = Tcl_NewStringObj(newPart2, -1); - if (createPart2) { - Tcl_IncrRefCount(part2Ptr); - } - - /* - * Free the internal rep of the original part1Ptr, now renamed - * objPtr, and set it to tclParsedVarNameType. - */ - - objPtr = part1Ptr; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclParsedVarNameType; - - /* - * Define a new string object to hold the new part1Ptr, i.e., - * the array name. Set the internal rep of objPtr, reset - * typePtr and part1 to contain the references to the array - * name. - */ + TclFreeIntRep(part1Ptr); - TclNewStringObj(part1Ptr, part1, len1); - Tcl_IncrRefCount(part1Ptr); - - objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + Tcl_IncrRefCount(arrayPtr); + part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr; + Tcl_IncrRefCount(part2Ptr); + part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr; + part1Ptr->typePtr = &tclParsedVarNameType; - typePtr = part1Ptr->typePtr; - part1 = TclGetString(part1Ptr); - break; - } + part1Ptr = arrayPtr; + } } } @@ -669,8 +612,6 @@ TclObjLookupVarEx( * the cached types if possible. */ - TclFreeIntRep(part1Ptr); - varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { @@ -679,9 +620,6 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } return NULL; } @@ -689,11 +627,12 @@ TclObjLookupVarEx( * Cache the newly found variable if possible. */ + TclFreeIntRep(part1Ptr); if (index >= 0) { /* * An indexed local variable. */ - Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); + Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); part1Ptr->typePtr = &localVarNameType; if (part1Ptr != cachedNamePtr) { @@ -730,9 +669,6 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } } return varPtr; } @@ -1131,6 +1067,7 @@ TclLookupArrayElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetVar const char * Tcl_GetVar( @@ -1151,6 +1088,7 @@ Tcl_GetVar( } return TclGetString(resultPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1309,7 +1247,7 @@ Tcl_ObjGetVar2( return NULL; } - return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, -1); } @@ -1339,6 +1277,52 @@ Tcl_Obj * TclPtrGetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ + Tcl_Var varPtr, /* The variable to be read.*/ + Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrGetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrGetVarIdx -- + * + * Return the value of a Tcl variable as a Tcl object, given the pointers + * to the variable's (and possibly containing array's) VAR structure. + * + * Results: + * The return value points to the current object value of the variable + * given by varPtr. 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 * +TclPtrGetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be looked up. */ register Var *varPtr, /* The variable to be read.*/ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ @@ -1474,6 +1458,7 @@ Tcl_SetObjCmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetVar const char * Tcl_SetVar( @@ -1486,18 +1471,15 @@ Tcl_SetVar( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); - - Tcl_IncrRefCount(varNamePtr); - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, Tcl_NewStringObj(newValue, -1), flags); - Tcl_DecrRefCount(varNamePtr); if (varValuePtr == NULL) { return NULL; } return TclGetString(varValuePtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1678,7 +1660,7 @@ Tcl_ObjSetVar2( return NULL; } - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, newValuePtr, flags, -1); } @@ -1711,6 +1693,60 @@ Tcl_Obj * TclPtrSetVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be looked up. */ + Tcl_Var varPtr, /* Reference to the variable to set. */ + Tcl_Var arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + Tcl_Obj *newValuePtr, /* New value for variable. */ + const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + * TCL_LEAVE_ERR_MSG bits. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + if (newValuePtr == NULL) { + Tcl_Panic("newValuePtr must not be NULL"); + } + return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, newValuePtr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrSetVarIdx -- + * + * This function is the same as Tcl_SetVar2Ex above, except that it + * requires pointers to the variable's Var structs in addition to the + * variable names. + * + * 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 * +TclPtrSetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be looked up. */ register Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a @@ -1953,7 +1989,7 @@ TclIncrObjVar2( "\n (reading value of variable to increment)"); return NULL; } - return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + return TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, incrPtr, flags, -1); } @@ -1986,6 +2022,62 @@ Tcl_Obj * TclPtrIncrObjVar( Tcl_Interp *interp, /* Command interpreter in which variable is to * be found. */ + Tcl_Var varPtr, /* Reference to the variable to set. */ + Tcl_Var arrayPtr, /* Reference to the array containing the + * variable, or NULL if the variable is a + * scalar. */ + Tcl_Obj *part1Ptr, /* Points to an object holding the name of an + * array (if part2 is non-NULL) or the name of + * a variable. */ + Tcl_Obj *part2Ptr, /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + Tcl_Obj *incrPtr, /* Increment value. */ +/* TODO: Which of these flag values really make sense? */ + const int flags) /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrIncrObjVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, incrPtr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrIncrObjVarIdx -- + * + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a Tcl_Obj increment. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the specified variable doesn't exist, or there is a clash + * in array usage, or an error occurs while executing variable traces, + * then NULL is returned and a message will be left in the interpreter's + * result. + * + * Side effects: + * The value of the given variable is incremented by the specified + * amount. If either the array or the entry didn't exist then a new + * variable is created. 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 * +TclPtrIncrObjVarIdx( + Tcl_Interp *interp, /* Command interpreter in which variable is to + * be found. */ Var *varPtr, /* Reference to the variable to set. */ Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a @@ -2011,8 +2103,8 @@ TclPtrIncrObjVar( if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - flags, index); + varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, flags, index); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; } @@ -2024,8 +2116,8 @@ TclPtrIncrObjVar( varValuePtr = Tcl_DuplicateObj(varValuePtr); if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - varValuePtr, flags, index); + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, varValuePtr, flags, index); } else { Tcl_DecrRefCount(varValuePtr); return NULL; @@ -2041,8 +2133,8 @@ TclPtrIncrObjVar( * is the way to make that happen. */ - return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, - varValuePtr, flags, index); + return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, + part2Ptr, varValuePtr, flags, index); } else { return NULL; } @@ -2069,6 +2161,7 @@ TclPtrIncrObjVar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UnsetVar int Tcl_UnsetVar( @@ -2097,6 +2190,7 @@ Tcl_UnsetVar( Tcl_DecrRefCount(varNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2189,8 +2283,8 @@ TclObjUnsetVar2( return TCL_ERROR; } - return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, - -1); + return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + flags, -1); } /* @@ -2219,6 +2313,53 @@ int TclPtrUnsetVar( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ + Tcl_Var varPtr, /* The variable to be unset. */ + Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + const int flags) /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG. */ +{ + if (varPtr == NULL) { + Tcl_Panic("varPtr must not be NULL"); + } + if (part1Ptr == NULL) { + Tcl_Panic("part1Ptr must not be NULL"); + } + return TclPtrUnsetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr, + part1Ptr, part2Ptr, flags, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrUnsetVarIdx -- + * + * Delete a variable, given the pointers to the variable's (and possibly + * containing array's) VAR structure. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. + * + * Side effects: + * If varPtr and arrayPtr indicate a local or global variable in interp, + * it is deleted. If varPtr is an array reference and part2Ptr is NULL, + * then the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclPtrUnsetVarIdx( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ register Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ @@ -2566,11 +2707,11 @@ Tcl_AppendObjCmd( /* * Note that we do not need to increase the refCount of the Var * pointers: should a trace delete the variable, the return value - * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not + * of TclPtrSetVarIdx will be NULL or emptyObjPtr, and we will not * access the variable again. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], + varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1); if ((varValuePtr == NULL) || (varValuePtr == ((Interp *) interp)->emptyObjPtr)) { @@ -2650,7 +2791,7 @@ Tcl_LappendObjCmd( createdNewObj = 0; /* - * Protect the variable pointers around the TclPtrGetVar call + * Protect the variable pointers around the TclPtrGetVarIdx call * to insure that they remain valid even if the variable was undefined * and unused. */ @@ -2666,7 +2807,7 @@ Tcl_LappendObjCmd( if (arrayPtr && TclIsVarInHash(arrayPtr)) { VarHashRefCount(arrayPtr)++; } - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL, + varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, TCL_LEAVE_ERR_MSG, -1); if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)--; @@ -2707,7 +2848,7 @@ Tcl_LappendObjCmd( * and we didn't create the variable. */ - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, + newValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, varValuePtr, TCL_LEAVE_ERR_MSG, -1); if (newValuePtr == NULL) { return TCL_ERROR; @@ -2808,7 +2949,7 @@ TclArraySet( keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { Tcl_DictObjDone(&search); return TCL_ERROR; @@ -2841,8 +2982,8 @@ TclArraySet( /* * We needn't worry about traces invalidating arrayPtr: should that be - * the case, TclPtrSetVar will return NULL so that we break out of the - * loop and return an error. + * the case, TclPtrSetVarIdx will return NULL so that we break out of + * the loop and return an error. */ copyListObj = TclListObjCopy(NULL, arrayElemObj); @@ -2851,7 +2992,7 @@ TclArraySet( elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, + (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ result = TCL_ERROR; break; @@ -2911,34 +3052,22 @@ TclArraySet( */ /* ARGSUSED */ -static int -ArrayStartSearchCmd( - ClientData clientData, + +static Var * +VerifyArray( Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) + Tcl_Obj *varNameObj) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_HashEntry *hPtr; - Tcl_Obj *varNameObj; - int isNew; - ArraySearch *searchPtr; - const char *varName; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - varNameObj = objv[1]; + const char *varName = TclGetString(varNameObj); + Var *arrayPtr; /* * Locate the array variable. */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - varName = TclGetString(varNameObj); /* * Special array trace used to keep the env array in sync for array names, @@ -2950,7 +3079,7 @@ ArrayStartSearchCmd( if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; + return NULL; } } @@ -2960,11 +3089,36 @@ ArrayStartSearchCmd( * traces. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { + if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); + return NULL; + } + + return varPtr; +} + +static int +ArrayStartSearchCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr; + Tcl_HashEntry *hPtr; + int isNew; + ArraySearch *searchPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + return TCL_ERROR; + } + + varPtr = VerifyArray(interp, objv[1]); + if (varPtr == NULL) { return TCL_ERROR; } @@ -2986,8 +3140,9 @@ ArrayStartSearchCmd( searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); + searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1])); + Tcl_IncrRefCount(searchPtr->name); + Tcl_SetObjResult(interp, searchPtr->name); return TCL_OK; } @@ -3017,7 +3172,7 @@ ArrayAnyMoreCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; ArraySearch *searchPtr; @@ -3029,39 +3184,8 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); + varPtr = VerifyArray(interp, varNameObj); + if (varPtr == NULL) { return TCL_ERROR; } @@ -3123,8 +3247,7 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; @@ -3135,39 +3258,8 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); + varPtr = VerifyArray(interp, varNameObj); + if (varPtr == NULL) { return TCL_ERROR; } @@ -3233,7 +3325,7 @@ ArrayDoneSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr, *prevPtr; @@ -3245,39 +3337,8 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); + varPtr = VerifyArray(interp, varNameObj); + if (varPtr == NULL) { return TCL_ERROR; } @@ -3311,6 +3372,7 @@ ArrayDoneSearchCmd( } } } + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); return TCL_OK; } @@ -4078,8 +4140,8 @@ ArrayUnsetCmd( if (!varPtr2 || TclIsVarUndefined(varPtr2)) { return TCL_OK; } - return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj, - unsetFlags, -1); + return TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, + patternObj, unsetFlags, -1); } /* @@ -4127,7 +4189,7 @@ ArrayUnsetCmd( nameObj = VarHashGetKey(varPtr2); if (Tcl_StringMatch(TclGetString(nameObj), pattern) - && TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, + && TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj, nameObj, unsetFlags, -1) != TCL_OK) { /* * If we incremented a refcount, we must decrement it here as we @@ -4193,7 +4255,7 @@ TclInitArrayCmd( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4274,7 +4336,7 @@ ObjMakeUpvar( } } - return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); + return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index); } /* @@ -4287,7 +4349,7 @@ ObjMakeUpvar( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4316,17 +4378,32 @@ TclPtrMakeUpvar( myNamePtr = Tcl_NewStringObj(myName, -1); Tcl_IncrRefCount(myNamePtr); } - result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); + result = TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, + index); if (myNamePtr) { Tcl_DecrRefCount(myNamePtr); } return result; } +int +TclPtrObjMakeUpvar( + Tcl_Interp *interp, /* Interpreter containing variables. Used for + * error messages, too. */ + Tcl_Var otherPtr, /* Pointer to the variable being linked-to. */ + Tcl_Obj *myNamePtr, /* Name of variable which will refer to + * otherP1/otherP2. Must be a scalar. */ + int myFlags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of myName. */ +{ + return TclPtrObjMakeUpvarIdx(interp, (Var *) otherPtr, myNamePtr, myFlags, + -1); +} + /* Callers must Incr myNamePtr if they plan to Decr it. */ int -TclPtrObjMakeUpvar( +TclPtrObjMakeUpvarIdx( Tcl_Interp *interp, /* Interpreter containing variables. Used for * error messages, too. */ Var *otherPtr, /* Pointer to the variable being linked-to. */ @@ -4463,6 +4540,7 @@ TclPtrObjMakeUpvar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UpVar int Tcl_UpVar( @@ -4496,6 +4574,7 @@ Tcl_UpVar( Tcl_DecrRefCount(localNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -4793,8 +4872,9 @@ Tcl_VariableObjCmd( */ if (i+1 < objc) { /* A value was specified. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr, - NULL, objv[i+1], TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG,-1); + varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, + varNamePtr, NULL, objv[i+1], + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -4950,75 +5030,6 @@ Tcl_UpvarObjCmd( /* *---------------------------------------------------------------------- * - * SetArraySearchObj -- - * - * This function converts the given tcl object into one that has the - * "array search" internal type. - * - * Results: - * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when - * an error message will be placed in the interpreter's result.) - * - * Side effects: - * Updates the internal type and representation of the object to make - * this an array-search object. See the tclArraySearchType declaration - * above for details of the internal representation. - * - *---------------------------------------------------------------------- - */ - -static int -SetArraySearchObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - const char *string; - char *end; /* Can't be const due to strtoul defn. */ - int id; - size_t offset; - - /* - * Get the string representation. Make it up-to-date if necessary. - */ - - string = TclGetString(objPtr); - - /* - * Parse the id into the three parts separated by dashes. - */ - - if ((string[0] != 's') || (string[1] != '-')) { - goto syntax; - } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - - /* - * Can't perform value check in this context, so place reference to place - * in string to use for the check in the object instead. - */ - - end++; - offset = end - string; - - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclArraySearchType; - objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); - return TCL_OK; - - syntax: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active @@ -5029,10 +5040,6 @@ SetArraySearchObj( * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. * - * Side effects: - * The tcl object might have its internal type and representation - * modified. - * *---------------------------------------------------------------------- */ @@ -5048,65 +5055,43 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - register const char *string; - register size_t offset; - int id; ArraySearch *searchPtr; - const char *varName = TclGetString(varNamePtr); - - /* - * Parse the id. - */ - - if ((handleObj->typePtr != &tclArraySearchType) - && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { - return NULL; - } - - /* - * Extract the information out of the Tcl_Obj. - */ - - id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); - string = TclGetString(handleObj); - offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); - - /* - * This test cannot be placed inside the Tcl_Obj machinery, since it is - * dependent on the variable context. - */ - - if (strcmp(string+offset, varName) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - string, varName)); - goto badLookup; - } - - /* - * Search through the list of active searches on the interpreter to see if - * the desired one exists. - * - * Note that we cannot store the searchPtr directly in the Tcl_Obj as that - * would run into trouble when DeleteSearches() was called so we must scan - * this list every time. - */ + const char *handle = TclGetString(handleObj); + char *end; if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + /* First look for same (Tcl_Obj *) */ + for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; + searchPtr = searchPtr->nextPtr) { + if (searchPtr->name == handleObj) { + return searchPtr; + } + } + /* Fallback: do string compares. */ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { - if (searchPtr->id == id) { + if (strcmp(TclGetString(searchPtr->name), handle) == 0) { return searchPtr; } } } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", string)); - badLookup: - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + if ((handle[0] != 's') || (handle[1] != '-') + || (strtoul(handle + 2, &end, 10), end == (handle + 2)) + || (*end != '-')) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", handle)); + } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + handle, TclGetString(varNamePtr))); + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", handle)); + } + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); return NULL; } @@ -5141,6 +5126,7 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; @@ -5514,28 +5500,6 @@ TclObjVarErrMsg( */ /* - * Panic functions that should never be called in normal operation. - */ - -static void -PanicOnUpdateVarName( - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "updateStringProc", - objPtr->typePtr->name); -} - -static int -PanicOnSetVarName( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", - objPtr->typePtr->name); - return TCL_ERROR; -} - -/* * localVarName - * * INTERNALREP DEFINITION: @@ -5588,11 +5552,11 @@ FreeParsedVarName( Tcl_Obj *objPtr) { register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - ckfree(elem); + TclDecrRefCount(elem); } objPtr->typePtr = NULL; } @@ -5603,58 +5567,17 @@ DupParsedVarName( Tcl_Obj *dupPtr) { register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; - char *elemCopy; - unsigned elemLen; + register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); - elemLen = strlen(elem); - elemCopy = ckalloc(elemLen + 1); - memcpy(elemCopy, elem, elemLen); - *(elemCopy + elemLen) = '\0'; - elem = elemCopy; + Tcl_IncrRefCount(elem); } dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; dupPtr->typePtr = &tclParsedVarNameType; } - -static void -UpdateParsedVarName( - Tcl_Obj *objPtr) -{ - Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - char *part2 = objPtr->internalRep.twoPtrValue.ptr2; - const char *part1; - char *p; - int len1, len2, totalLen; - - if (arrayPtr == NULL) { - /* - * This is a parsed scalar name: what is it doing here? - */ - - Tcl_Panic("scalar parsedVarName without a string rep"); - } - - part1 = TclGetStringFromObj(arrayPtr, &len1); - len2 = strlen(part2); - - totalLen = len1 + len2 + 2; - p = ckalloc(totalLen + 1); - objPtr->bytes = p; - objPtr->length = totalLen; - - memcpy(p, part1, (unsigned) len1); - p += len1; - *p++ = '('; - memcpy(p, part2, (unsigned) len2); - p += len2; - *p++ = ')'; - *p = '\0'; -} /* *---------------------------------------------------------------------- |