summaryrefslogtreecommitdiffstats
path: root/generic/tclVar.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclVar.c')
-rw-r--r--generic/tclVar.c265
1 files changed, 170 insertions, 95 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1c01e41..4694cd8 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -47,6 +47,13 @@ static inline void CleanupVar(Var *varPtr, Var *arrayPtr);
#define VarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+/*
+ * NOTE: VarHashCreateVar increments the recount of its key argument.
+ * All callers that will call Tcl_DecrRefCount on that argument must
+ * call Tcl_IncrRefCount on it before passing it in. This requirement
+ * can bubble up to callers of callers .... etc.
+ */
+
static inline Var *
VarHashCreateVar(
TclVarHashTable *tablePtr,
@@ -137,6 +144,30 @@ static const char *isArrayElement =
#define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC)
/*
+ * The following structure describes an enumerative search in progress on an
+ * array variable; this are invoked with options to the "array" command.
+ */
+
+typedef struct ArraySearch {
+ int id; /* Integer id used to distinguish among
+ * multiple concurrent searches for the same
+ * array. */
+ struct Var *varPtr; /* Pointer to array variable that's being
+ * searched. */
+ Tcl_HashSearch search; /* Info kept by the hash module about progress
+ * through the array. */
+ Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to
+ * be enumerated (it's leftover from the
+ * Tcl_FirstHashEntry call or from an "array
+ * anymore" command). NULL means must call
+ * Tcl_NextHashEntry to get value to
+ * return. */
+ struct ArraySearch *nextPtr;/* Next in list of all active searches for
+ * this variable, or NULL if this is the last
+ * one. */
+} ArraySearch;
+
+/*
* Forward references to functions defined later in this file:
*/
@@ -383,11 +414,12 @@ TclLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part1Ptr;
Var *varPtr;
+ Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
+ if (createPart1) {
+ Tcl_IncrRefCount(part1Ptr);
+ }
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
createPart1, createPart2, arrayPtrPtr);
@@ -432,6 +464,8 @@ TclLookupVar(
* are 1. The object part1Ptr is converted to one of localVarNameType,
* tclNsVarNameType or tclParsedVarNameType and caches as much of the
* lookup as it can.
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
*
*----------------------------------------------------------------------
*/
@@ -460,14 +494,14 @@ TclObjLookupVar(
* address of array variable. Otherwise this
* is set to NULL. */
{
- Tcl_Obj *part2Ptr;
+ Tcl_Obj *part2Ptr = NULL;
Var *resPtr;
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
@@ -480,6 +514,12 @@ TclObjLookupVar(
return resPtr;
}
+/*
+ * When createPart1 is 1, callers must IncrRefCount part1Ptr if they
+ * plan to DecrRefCount it.
+ * When createPart2 is 1, callers must IncrRefCount part2Ptr if they
+ * plan to DecrRefCount it.
+ */
Var *
TclObjLookupVarEx(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
@@ -620,7 +660,9 @@ TclObjLookupVarEx(
part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2;
if (newPart2) {
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
}
part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
@@ -666,7 +708,9 @@ TclObjLookupVarEx(
*(newPart2+len2) = '\0';
part2 = newPart2;
part2Ptr = Tcl_NewStringObj(newPart2, -1);
- Tcl_IncrRefCount(part2Ptr);
+ if (createPart2) {
+ Tcl_IncrRefCount(part2Ptr);
+ }
/*
* Free the internal rep of the original part1Ptr, now renamed
@@ -847,6 +891,7 @@ TclObjLookupVarEx(
*
* Side effects:
* A new hashtable entry may be created if create is 1.
+ * Callers must Incr varNamePtr if they plan to Decr it if create is 1.
*
*----------------------------------------------------------------------
*/
@@ -1075,6 +1120,8 @@ TclLookupSimpleVar(
* The variable at arrayPtr may be converted to be an array if
* createPart1 is 1. A new hashtable entry may be created if createPart2
* is 1.
+ * When createElem is 1, callers must incr elNamePtr if they plan
+ * to decr it.
*
*----------------------------------------------------------------------
*/
@@ -1200,6 +1247,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#undef Tcl_GetVar
const char *
Tcl_GetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -1209,11 +1257,9 @@ Tcl_GetVar(
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
- Tcl_Obj *varNamePtr, *resultPtr;
+ Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
+ Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
- varNamePtr = Tcl_NewStringObj(varName, -1);
- Tcl_IncrRefCount(varNamePtr);
- resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
TclDecrRefCount(varNamePtr);
if (resultPtr == NULL) {
@@ -1257,15 +1303,12 @@ Tcl_GetVar2(
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG *
* bits. */
{
- Tcl_Obj *resultPtr, *part1Ptr, *part2Ptr;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resultPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1314,15 +1357,11 @@ Tcl_GetVar2Ex(
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
* TCL_LEAVE_ERR_MSG bits. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);
@@ -1355,6 +1394,8 @@ Tcl_GetVar2Ex(
* the returned reference; if you want to keep a reference to the object
* you must increment its ref count yourself.
*
+ * Callers must incr part2Ptr if they plan to decr it.
+ *
*----------------------------------------------------------------------
*/
@@ -1549,6 +1590,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetVar
const char *
Tcl_SetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -1560,17 +1602,13 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *varNamePtr, *varValuePtr;
+ Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
- varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
-
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, valuePtr, flags);
-
+ varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_NewStringObj(newValue, -1), flags);
Tcl_DecrRefCount(varNamePtr);
- Tcl_DecrRefCount(valuePtr);
+
if (varValuePtr == NULL) {
return NULL;
}
@@ -1618,27 +1656,9 @@ Tcl_SetVar2(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *valuePtr, *part1Ptr, *part2Ptr;
- Tcl_Obj *varValuePtr;
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,
+ Tcl_NewStringObj(newValue, -1), flags);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
- if (part2 != NULL) {
- part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
- }
- valuePtr = Tcl_NewStringObj(newValue, -1);
- Tcl_IncrRefCount(valuePtr);
-
- varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, flags);
-
- Tcl_DecrRefCount(part1Ptr);
- if (part2Ptr != NULL) {
- Tcl_DecrRefCount(part2Ptr);
- }
- Tcl_DecrRefCount(valuePtr);
if (varValuePtr == NULL) {
return NULL;
}
@@ -1697,15 +1717,12 @@ Tcl_SetVar2Ex(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *part1Ptr, *part2Ptr, *resPtr;
+ Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
Tcl_IncrRefCount(part2Ptr);
- } else {
- part2Ptr = NULL;
}
resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);
@@ -1738,6 +1755,8 @@ Tcl_SetVar2Ex(
* 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.
+ * Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2027,6 +2046,8 @@ TclPtrSetVar(
* 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.
+ * Callers must Incr part1Ptr if they plan to Decr it.
+ * Callers must Incr part2Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -2052,8 +2073,8 @@ TclIncrObjVar2(
varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read",
1, 1, &arrayPtr);
if (varPtr == NULL) {
- Tcl_AddObjErrorInfo(interp,
- "\n (reading value of variable to increment)", -1);
+ Tcl_AddErrorInfo(interp,
+ "\n (reading value of variable to increment)");
return NULL;
}
return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
@@ -2109,8 +2130,7 @@ TclPtrIncrObjVar(
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
- register Tcl_Obj *varValuePtr, *newValuePtr = NULL;
- int duplicated, code;
+ register Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
@@ -2124,19 +2144,33 @@ TclPtrIncrObjVar(
varValuePtr = Tcl_NewIntObj(0);
}
if (Tcl_IsShared(varValuePtr)) {
- duplicated = 1;
+ /* Copy on write */
varValuePtr = Tcl_DuplicateObj(varValuePtr);
+
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ Tcl_DecrRefCount(varValuePtr);
+ return NULL;
+ }
} else {
- duplicated = 0;
- }
- code = TclIncrObj(interp, varValuePtr, incrPtr);
- if (code == TCL_OK) {
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
- part2Ptr, varValuePtr, flags, index);
- } else if (duplicated) {
- Tcl_DecrRefCount(varValuePtr);
+ /* Unshared - can Incr in place */
+ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
+
+ /*
+ * This seems dumb to write the incremeted value into the var
+ * after we just adjusted the value in place, but the spec for
+ * [incr] requires that write traces fire, and making this call
+ * is the way to make that happen.
+ */
+
+ return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ varValuePtr, flags, index);
+ } else {
+ return NULL;
+ }
}
- return newValuePtr;
}
/*
@@ -2159,6 +2193,7 @@ TclPtrIncrObjVar(
*----------------------------------------------------------------------
*/
+#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -2219,13 +2254,10 @@ Tcl_UnsetVar2(
* TCL_LEAVE_ERR_MSG. */
{
int result;
- Tcl_Obj *part1Ptr, *part2Ptr = NULL;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
}
/*
@@ -2841,6 +2873,7 @@ Tcl_LappendObjCmd(
*
* Side effects:
* A variable will be created if one does not already exist.
+ * Callers must Incr arrayNameObj if they pland to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -3817,6 +3850,53 @@ ArrayNamesCmd(
/*
*----------------------------------------------------------------------
*
+ * TclFindArrayPtrElements --
+ *
+ * Fill out a hash table (which *must* use Tcl_Obj* keys) with an entry
+ * for each existing element of the given array. The provided hash table
+ * is assumed to be initially empty.
+ *
+ * Result:
+ * none
+ *
+ * Side effects:
+ * The keys of the array gain an extra reference. The supplied hash table
+ * has elements added to it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFindArrayPtrElements(
+ Var *arrayPtr,
+ Tcl_HashTable *tablePtr)
+{
+ Var *varPtr;
+ Tcl_HashSearch search;
+
+ if ((arrayPtr == NULL) || !TclIsVarArray(arrayPtr)
+ || TclIsVarUndefined(arrayPtr)) {
+ return;
+ }
+
+ for (varPtr=VarHashFirstVar(arrayPtr->value.tablePtr, &search);
+ varPtr!=NULL ; varPtr=VarHashNextVar(&search)) {
+ Tcl_HashEntry *hPtr;
+ Tcl_Obj *nameObj;
+ int dummy;
+
+ if (TclIsVarUndefined(varPtr)) {
+ continue;
+ }
+ nameObj = VarHashGetKey(varPtr);
+ hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy);
+ Tcl_SetHashValue(hPtr, nameObj);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ArraySetCmd --
*
* This object-based function is invoked to process the "array set" Tcl
@@ -4222,16 +4302,16 @@ TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
- {"anymore", ArrayAnyMoreCmd, NULL, NULL, NULL, 0},
- {"donesearch", ArrayDoneSearchCmd, NULL, NULL, NULL, 0},
+ {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
+ {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
- {"get", ArrayGetCmd, NULL, NULL, NULL, 0},
- {"names", ArrayNamesCmd, NULL, NULL, NULL, 0},
- {"nextelement", ArrayNextElementCmd, NULL, NULL, NULL, 0},
+ {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
+ {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"set", ArraySetCmd, TclCompileArraySetCmd, NULL, NULL, 0},
- {"size", ArraySizeCmd, NULL, NULL, NULL, 0},
- {"startsearch", ArrayStartSearchCmd, NULL, NULL, NULL, 0},
- {"statistics", ArrayStatsCmd, NULL, NULL, NULL, 0},
+ {"size", ArraySizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"startsearch", ArrayStartSearchCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
+ {"statistics", ArrayStatsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0},
{"unset", ArrayUnsetCmd, TclCompileArrayUnsetCmd, NULL, NULL, 0},
{NULL, NULL, NULL, NULL, NULL, 0}
};
@@ -4255,6 +4335,8 @@ TclInitArrayCmd(
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
+ * Callers must Incr myNamePtr if they plan to Decr it.
+ * Callers must Incr otherP1Ptr if they plan to Decr it.
*
*----------------------------------------------------------------------
*/
@@ -4363,14 +4445,12 @@ TclPtrMakeUpvar(
int index) /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1 */
{
- Tcl_Obj *myNamePtr;
+ Tcl_Obj *myNamePtr = NULL;
int result;
if (myName) {
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
- } else {
- myNamePtr = NULL;
}
result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
if (myNamePtr) {
@@ -4379,6 +4459,8 @@ TclPtrMakeUpvar(
return result;
}
+/* Callers must Incr myNamePtr if they plan to Decr it. */
+
int
TclPtrObjMakeUpvar(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
@@ -4518,6 +4600,7 @@ TclPtrObjMakeUpvar(
*----------------------------------------------------------------------
*/
+#undef Tcl_UpVar
int
Tcl_UpVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
@@ -5111,7 +5194,8 @@ ParseSearchId(
* Parse the id.
*/
- if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
+ if ((handleObj->typePtr != &tclArraySearchType)
+ && (SetArraySearchObj(interp, handleObj) != TCL_OK)) {
return NULL;
}
@@ -5242,8 +5326,6 @@ TclDeleteNamespaceVars(
for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL;
varPtr = VarHashFirstVar(tablePtr, &search)) {
Tcl_Obj *objPtr = Tcl_NewObj();
-
- Tcl_IncrRefCount(objPtr);
VarHashRefCount(varPtr)++; /* Make sure we get to remove from
* hash. */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
@@ -5507,15 +5589,10 @@ TclVarErrMsg(
* e.g. "read", "set", or "unset". */
const char *reason) /* String describing why operation failed. */
{
- Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL;
+ Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);
- part1Ptr = Tcl_NewStringObj(part1, -1);
- Tcl_IncrRefCount(part1Ptr);
if (part2) {
part2Ptr = Tcl_NewStringObj(part2, -1);
- Tcl_IncrRefCount(part2Ptr);
- } else {
- part2 = NULL;
}
TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);
@@ -5788,7 +5865,6 @@ Tcl_FindNamespaceVar(
Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
Tcl_Var var;
- Tcl_IncrRefCount(namePtr);
var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
Tcl_DecrRefCount(namePtr);
return var;
@@ -5883,7 +5959,6 @@ ObjFindNamespaceVar(
varPtr = NULL;
if (simpleName != name) {
simpleNamePtr = Tcl_NewStringObj(simpleName, -1);
- Tcl_IncrRefCount(simpleNamePtr);
} else {
simpleNamePtr = namePtr;
}