summaryrefslogtreecommitdiffstats
path: root/generic/tclVar.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclVar.c')
-rw-r--r--generic/tclVar.c606
1 files changed, 308 insertions, 298 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 7c8bb73..9ad455d 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -149,7 +149,6 @@ 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. */
@@ -189,7 +188,8 @@ 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 Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj);
+static int SetArraySearchObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
/*
* Functions defined in this file that may be exported in the future for use
@@ -214,6 +214,10 @@ static Tcl_DupInternalRepProc DupParsedVarName;
* or NULL if it is this same obj
* twoPtrValue.ptr2: index into locals table
*
+ * nsVarName - INTERNALREP DEFINITION:
+ * twoPtrValue.ptr1: pointer to the namespace containing the reference
+ * twoPtrValue.ptr2: pointer to the corresponding Var
+ *
* parsedVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the array name Tcl_Obj, or NULL if it is a
* scalar variable
@@ -231,6 +235,22 @@ static const Tcl_ObjType tclParsedVarNameType = {
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(
@@ -1048,51 +1068,6 @@ TclLookupArrayElement(
/*
*----------------------------------------------------------------------
*
- * Tcl_GetVar --
- *
- * Return the value of a Tcl variable as a string.
- *
- * Results:
- * The return value points to the current value of varName as a string.
- * If the variable is not defined or can't be read because of a clash in
- * array usage then a NULL pointer is returned and an error message is
- * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
- * Note: the return value is only valid up until the next change to the
- * variable; if you depend on the value lasting longer than that, then
- * make yourself a private copy.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-#ifndef TCL_NO_DEPRECATED
-#undef Tcl_GetVar
-const char *
-Tcl_GetVar(
- Tcl_Interp *interp, /* Command interpreter in which varName is to
- * be looked up. */
- const char *varName, /* Name of a variable in interp. */
- int flags) /* OR-ed combination of TCL_GLOBAL_ONLY,
- * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
- * bits. */
-{
- Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
-
- TclDecrRefCount(varNamePtr);
-
- if (resultPtr == NULL) {
- return NULL;
- }
- return TclGetString(resultPtr);
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_GetVar2 --
*
* Return the value of a Tcl variable as a string, given a two-part name
@@ -1437,53 +1412,6 @@ Tcl_SetObjCmd(
/*
*----------------------------------------------------------------------
*
- * Tcl_SetVar --
- *
- * Change the value of a variable.
- *
- * Results:
- * Returns a pointer to the malloc'ed string which is the character
- * representation of the variable's new value. The caller must not modify
- * this string. If the write operation was disallowed then NULL is
- * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
- * message will be left in the interp's result. Note that the returned
- * string may not be the same as newValue; this is because variable
- * traces may modify the variable's value.
- *
- * Side effects:
- * If varName is defined as a local or global variable in interp, its
- * value is changed to newValue. If varName isn't currently defined, then
- * a new global variable by that name is created.
- *
- *----------------------------------------------------------------------
- */
-
-#ifndef TCL_NO_DEPRECATED
-#undef Tcl_SetVar
-const char *
-Tcl_SetVar(
- Tcl_Interp *interp, /* Command interpreter in which varName is to
- * be looked up. */
- const char *varName, /* Name of a variable in interp. */
- const char *newValue, /* New value for varName. */
- 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. */
-{
- Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL,
- Tcl_NewStringObj(newValue, -1), flags);
-
- if (varValuePtr == NULL) {
- return NULL;
- }
- return TclGetString(varValuePtr);
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_SetVar2 --
*
* Given a two-part variable name, which may refer either to a scalar
@@ -2109,7 +2037,7 @@ TclPtrIncrObjVarIdx(
VarHashRefCount(varPtr)--;
}
if (varValuePtr == NULL) {
- varValuePtr = Tcl_NewIntObj(0);
+ varValuePtr = Tcl_NewLongObj(0);
}
if (Tcl_IsShared(varValuePtr)) {
/* Copy on write */
@@ -2144,57 +2072,6 @@ TclPtrIncrObjVarIdx(
/*
*----------------------------------------------------------------------
*
- * Tcl_UnsetVar --
- *
- * Delete a variable, so that it may not be accessed anymore.
- *
- * 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 varName is defined as a local or global variable in interp, it is
- * deleted.
- *
- *----------------------------------------------------------------------
- */
-
-#ifndef TCL_NO_DEPRECATED
-#undef Tcl_UnsetVar
-int
-Tcl_UnsetVar(
- Tcl_Interp *interp, /* Command interpreter in which varName is to
- * be looked up. */
- const char *varName, /* Name of a variable in interp. May be either
- * a scalar name or an array name or an
- * element in an array. */
- int flags) /* OR-ed combination of any of
- * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
- * TCL_LEAVE_ERR_MSG. */
-{
- int result;
- Tcl_Obj *varNamePtr;
-
- varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(varNamePtr);
-
- /*
- * Filter to pass through only the flags this interface supports.
- */
-
- flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
- result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags);
-
- Tcl_DecrRefCount(varNamePtr);
- return result;
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_UnsetVar2 --
*
* Delete a variable, given a 2-part name.
@@ -3052,22 +2929,34 @@ TclArraySet(
*/
/* ARGSUSED */
-
-static Var *
-VerifyArray(
+static int
+ArrayStartSearchCmd(
+ ClientData clientData,
Tcl_Interp *interp,
- Tcl_Obj *varNameObj)
+ int objc,
+ Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- const char *varName = TclGetString(varNameObj);
- Var *arrayPtr;
+ 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];
/*
* Locate the array variable.
*/
- Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
+ 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,
@@ -3079,7 +2968,7 @@ VerifyArray(
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 NULL;
+ return TCL_ERROR;
}
}
@@ -3089,36 +2978,11 @@ VerifyArray(
* 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;
}
@@ -3140,9 +3004,8 @@ ArrayStartSearchCmd(
searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
Tcl_SetHashValue(hPtr, searchPtr);
- searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
- Tcl_IncrRefCount(searchPtr->name);
- Tcl_SetObjResult(interp, searchPtr->name);
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
return TCL_OK;
}
@@ -3172,7 +3035,7 @@ ArrayAnyMoreCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- Var *varPtr;
+ Var *varPtr, *arrayPtr;
Tcl_Obj *varNameObj, *searchObj;
int gotValue;
ArraySearch *searchPtr;
@@ -3184,8 +3047,39 @@ ArrayAnyMoreCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ /*
+ * 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);
return TCL_ERROR;
}
@@ -3247,7 +3141,8 @@ ArrayNextElementCmd(
int objc,
Tcl_Obj *const objv[])
{
- Var *varPtr;
+ Interp *iPtr = (Interp *) interp;
+ Var *varPtr, *arrayPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
@@ -3258,8 +3153,39 @@ ArrayNextElementCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ /*
+ * 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);
return TCL_ERROR;
}
@@ -3325,7 +3251,7 @@ ArrayDoneSearchCmd(
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
- Var *varPtr;
+ Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr, *prevPtr;
@@ -3337,8 +3263,39 @@ ArrayDoneSearchCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ /*
+ * 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);
return TCL_ERROR;
}
@@ -3372,7 +3329,6 @@ ArrayDoneSearchCmd(
}
}
}
- Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
}
@@ -3696,8 +3652,8 @@ ArrayNamesCmd(
* Finish parsing the arguments.
*/
- if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option",
- 0, &mode) != TCL_OK) {
+ if ((objc == 4) && Tcl_GetIndexFromObjStruct(interp, objv[2], options,
+ sizeof(char *), "option", 0, &mode) != TCL_OK) {
return TCL_ERROR;
}
@@ -3956,7 +3912,7 @@ ArraySizeCmd(
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(size));
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(size));
return TCL_OK;
}
@@ -4255,7 +4211,7 @@ TclInitArrayCmd(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in interp.
+ * message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4349,7 +4305,7 @@ ObjMakeUpvar(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in interp.
+ * message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4522,63 +4478,6 @@ TclPtrObjMakeUpvarIdx(
/*
*----------------------------------------------------------------------
*
- * Tcl_UpVar --
- *
- * This function links one variable to another, just like the "upvar"
- * command.
- *
- * Results:
- * A standard Tcl completion code. If an error occurs then an error
- * message is left in the interp's result.
- *
- * Side effects:
- * The variable in frameName whose name is given by varName becomes
- * accessible under the name localNameStr, so that references to
- * localNameStr are redirected to the other variable like a symbolic
- * link.
- *
- *----------------------------------------------------------------------
- */
-
-#ifndef TCL_NO_DEPRECATED
-#undef Tcl_UpVar
-int
-Tcl_UpVar(
- Tcl_Interp *interp, /* Command interpreter in which varName is to
- * be looked up. */
- const char *frameName, /* Name of the frame containing the source
- * variable, such as "1" or "#0". */
- const char *varName, /* Name of a variable in interp to link to.
- * May be either a scalar name or an element
- * in an array. */
- const char *localNameStr, /* Name of link variable. */
- int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
- * indicates scope of localNameStr. */
-{
- int result;
- CallFrame *framePtr;
- Tcl_Obj *varNamePtr, *localNamePtr;
-
- if (TclGetFrame(interp, frameName, &framePtr) == -1) {
- return TCL_ERROR;
- }
-
- varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(varNamePtr);
- localNamePtr = Tcl_NewStringObj(localNameStr, -1);
- Tcl_IncrRefCount(localNamePtr);
-
- result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0,
- localNamePtr, flags, -1);
- Tcl_DecrRefCount(varNamePtr);
- Tcl_DecrRefCount(localNamePtr);
- return result;
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_UpVar2 --
*
* This function links one variable to another, just like the "upvar"
@@ -5030,6 +4929,75 @@ 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
@@ -5040,6 +5008,10 @@ Tcl_UpvarObjCmd(
* 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.
+ *
*----------------------------------------------------------------------
*/
@@ -5055,43 +5027,65 @@ ParseSearchId(
* name. */
{
Interp *iPtr = (Interp *) interp;
+ register const char *string;
+ register size_t offset;
+ int id;
ArraySearch *searchPtr;
- const char *handle = TclGetString(handleObj);
- char *end;
+ 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.
+ */
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) {
+ if (searchPtr->id == id) {
return searchPtr;
}
}
- /* Fallback: do string compares. */
- for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL;
- searchPtr = searchPtr->nextPtr) {
- if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
- return searchPtr;
- }
- }
- }
- 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);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "couldn't find search \"%s\"", string));
+ badLookup:
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL);
return NULL;
}
@@ -5126,7 +5120,6 @@ DeleteSearches(
for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
- Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
@@ -5255,27 +5248,44 @@ TclDeleteVars(
TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
- Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
register Var *varPtr;
- int flags;
- Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
-
- /*
- * Determine what flags to pass to the trace callback functions.
- */
-
- flags = TCL_TRACE_UNSETS;
- if (tablePtr == &iPtr->globalNsPtr->varTable) {
- flags |= TCL_GLOBAL_ONLY;
- } else if (tablePtr == &currNsPtr->varTable) {
- flags |= TCL_NAMESPACE_ONLY;
- }
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
- UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags,
- -1);
+ VarHashRefCount(varPtr)++;
+
+ UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr),
+ NULL, TCL_TRACE_UNSETS, -1);
+
+ if (TclIsVarTraced(varPtr)) {
+ Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
+ VarTrace *tracePtr = Tcl_GetHashValue(tPtr);
+ ActiveVarTrace *activePtr;
+
+ while (tracePtr) {
+ VarTrace *prevPtr = tracePtr;
+
+ tracePtr = tracePtr->nextPtr;
+ prevPtr->nextPtr = NULL;
+ Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
+ }
+ Tcl_DeleteHashEntry(tPtr);
+ varPtr->flags &= ~VAR_ALL_TRACES;
+ for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
+ activePtr = activePtr->nextPtr) {
+ if (activePtr->varPtr == varPtr) {
+ activePtr->nextTracePtr = NULL;
+ }
+ }
+ }
+
+ if (!TclIsVarUndefined(varPtr)) {
+ UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr),
+ NULL, TCL_TRACE_UNSETS, -1);
+ }
+
+ VarHashRefCount(varPtr)--;
VarHashDeleteEntry(varPtr);
}
VarHashDeleteTable(tablePtr);
generated by cgit v0.12 at 2025-06-03 04:11:33 (GMT)