diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 715 |
1 files changed, 365 insertions, 350 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index 70efd00..03b7757 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -14,7 +14,7 @@ * 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.7 1999/02/03 00:55:06 stanton Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.8 1999/04/16 00:46:55 stanton Exp $ */ #include "tclInt.h" @@ -77,9 +77,7 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, * * If the variable isn't found and creation wasn't specified, or some * other error occurs, NULL is returned and an error message is left in - * interp->result if TCL_LEAVE_ERR_MSG is set in flags. (The result - * isn't put in interp->objResultPtr because this procedure is used - * by so many string-based routines.) + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. * * Note: it's possible for the variable returned to be VAR_UNDEFINED * even if createPart1 or createPart2 are 1 (these only cause the hash @@ -99,17 +97,13 @@ Var * TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - char *part1; /* If part2 isn't NULL, this is the name of - * an array. Otherwise, if the - * TCL_PARSE_PART1 flag bit is set this + register char *part1; /* If part2 isn't NULL, this is the name of + * an array. Otherwise, this * is a full variable name that could - * include a parenthesized array elemnt. If - * TCL_PARSE_PART1 isn't present, then - * this is the name of a scalar variable. */ + * include a parenthesized array element. */ char *part2; /* Name of element within array, or NULL. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG, and - * TCL_PARSE_PART1 bits matter. */ + * and TCL_LEAVE_ERR_MSG bits matter. */ char *msg; /* Verb to use in error messages, e.g. * "read" or "set". Only needed if * TCL_LEAVE_ERR_MSG is set in flags. */ @@ -155,33 +149,38 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ /* - * If the name hasn't been parsed into array name and index yet, - * do it now. + * Parse part1 into array name and index. + * Always check if part1 is an array element name and allow it only if + * part2 is not given. + * (if one does not care about creating array elements that can't be used + * from tcl, and prefer slightly better performance, one can put + * the following in an if (part2 == NULL) { ... } block and remove + * the part2's test and error reporting or move that code in array set) */ elName = part2; - if (flags & TCL_PARSE_PART1) { - for (p = part1; ; p++) { - if (*p == 0) { - elName = NULL; - break; - } - if (*p == '(') { - openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { - closeParen = p; - *openParen = 0; - elName = openParen+1; - } else { + for (p = part1; *p ; p++) { + if (*p == '(') { + openParen = p; + do { + p++; + } while (*p != '\0'); + p--; + if (*p == ')') { + if (part2 != NULL) { openParen = NULL; - elName = NULL; + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + goto done; } - break; + closeParen = p; + *openParen = 0; + elName = openParen+1; + } else { + openParen = NULL; } + break; } } @@ -259,6 +258,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (createPart1) { /* var wasn't found so create it */ 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); @@ -292,7 +292,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { - char *localName = localVarPtr->name; + register char *localName = localVarPtr->name; if ((part1[0] == localName[0]) && (part1Len == localPtr->nameLength) && (strcmp(part1, localName) == 0)) { @@ -451,7 +451,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * 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 interp->result if the TCL_LEAVE_ERR_MSG flag is set. + * 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. @@ -471,8 +471,7 @@ Tcl_GetVar(interp, varName, flags) * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ { - return Tcl_GetVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1)); + return Tcl_GetVar2(interp, varName, (char *) NULL, flags); } /* @@ -487,7 +486,7 @@ Tcl_GetVar(interp, varName, flags) * The return value points to the current value of the variable given * by part1 and part2 as a string. 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 interp->result if the + * and a message will be 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. @@ -507,53 +506,17 @@ Tcl_GetVar2(interp, part1, part2, flags) char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_LEAVE_ERR_MSG, - * and TCL_PARSE_PART1 bits. */ + * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG + * bits. */ { - register Tcl_Obj *part1Ptr; - register Tcl_Obj *part2Ptr = NULL; Tcl_Obj *objPtr; - int length; - - length = strlen(part1); - TclNewObj(part1Ptr); - TclInitStringRep(part1Ptr, part1, length); - Tcl_IncrRefCount(part1Ptr); - if (part2 != NULL) { - length = strlen(part2); - TclNewObj(part2Ptr); - TclInitStringRep(part2Ptr, part2, length); - Tcl_IncrRefCount(part2Ptr); - } - - objPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - - TclDecrRefCount(part1Ptr); /* done with the part1 name object */ - if (part2Ptr != NULL) { - TclDecrRefCount(part2Ptr); /* and the part2 name object */ - } - + objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); if (objPtr == NULL) { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); return NULL; } - - /* - * THIS FAILS IF Tcl_ObjGetVar2's RESULT'S STRING REP HAS A NULL BYTE. - */ - - return TclGetStringFromObj(objPtr, (int *) NULL); + return TclGetString(objPtr); } - /* *---------------------------------------------------------------------- * @@ -591,20 +554,57 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) * 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_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. + * + * 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_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) + * or the name of a variable. */ + char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ +{ Interp *iPtr = (Interp *) interp; register Var *varPtr; Var *arrayPtr; - char *part1, *msg; - char *part2 = NULL; - - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ + char *msg; - part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); - if (part2Ptr != NULL) { - part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); - } varPtr = TclLookupVar(interp, part1, part2, flags, "read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -618,7 +618,7 @@ Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_READS); + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "read", msg); @@ -687,7 +687,7 @@ Tcl_Obj * TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - int localIndex; /* Index of variable in procedure's array + register int localIndex; /* Index of variable in procedure's array * of local variables. */ int leaveErrorMsg; /* 1 if to leave an error message in * interpreter's result on an error. @@ -700,14 +700,13 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) * the current procedure's frame, if any, * unless an "uplevel" is executing. */ Var *compiledLocals = varFramePtr->compiledLocals; - Var *varPtr; /* Points to the variable's in-frame Var + register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ char *varName; /* Name of the local variable. */ char *msg; #ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; + int localCt = varFramePtr->procPtr->numCompiledLocals; if (compiledLocals == NULL) { fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", @@ -743,7 +742,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) if (varPtr->tracePtr != NULL) { msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); + TCL_TRACE_READS); if (msg != NULL) { if (leaveErrorMsg) { VarErrMsg(interp, varName, NULL, "read", msg); @@ -765,6 +764,7 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) msg = noSuchVar; } VarErrMsg(interp, varName, NULL, "read", msg); + } return NULL; } @@ -843,11 +843,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) } #endif /* TCL_COMPILE_DEBUG */ - /* - * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + elem = TclGetString(elemPtr); arrayPtr = &(compiledLocals[localIndex]); arrayName = arrayPtr->name; @@ -945,7 +941,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) /* *---------------------------------------------------------------------- * - * Tcl_SetCmd -- + * Tcl_SetObjCmd -- * * This procedure is invoked to process the "set" Tcl command. * See the user documentation for details on what it does. @@ -961,35 +957,32 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) /* ARGSUSED */ int -Tcl_SetCmd(dummy, interp, argc, argv) +Tcl_SetObjCmd(dummy, interp, objc, objv) ClientData dummy; /* Not used. */ register Tcl_Interp *interp; /* Current interpreter. */ - int argc; /* Number of arguments. */ - char **argv; /* Argument strings. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { - if (argc == 2) { - char *value; + Tcl_Obj *varValueObj; - value = Tcl_GetVar2(interp, argv[1], (char *) NULL, - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (value == NULL) { + if (objc == 2) { + varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (varValueObj == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, value, TCL_VOLATILE); + Tcl_SetObjResult(interp, varValueObj); return TCL_OK; - } else if (argc == 3) { - char *result; + } else if (objc == 3) { - result = Tcl_SetVar2(interp, argv[1], (char *) NULL, argv[2], - TCL_LEAVE_ERR_MSG|TCL_PARSE_PART1); - if (result == NULL) { + varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], + TCL_LEAVE_ERR_MSG); + if (varValueObj == NULL) { return TCL_ERROR; } - Tcl_SetResult(interp, result, TCL_VOLATILE); + Tcl_SetObjResult(interp, varValueObj); return TCL_OK; } else { - Tcl_AppendResult(interp, "wrong # args: should be \"", - argv[0], " varName ?newValue?\"", (char *) NULL); + Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?"); return TCL_ERROR; } } @@ -1006,7 +999,7 @@ Tcl_SetCmd(dummy, interp, argc, argv) * 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 interp->result. Note that the + * 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. * @@ -1029,8 +1022,7 @@ Tcl_SetVar(interp, varName, newValue, flags) * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { - return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, - (flags | TCL_PARSE_PART1)); + return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags); } /* @@ -1049,7 +1041,7 @@ Tcl_SetVar(interp, varName, newValue, flags) * modify this string. 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 interp->result. Note that the returned + * 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. * @@ -1073,70 +1065,86 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) 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. */ + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */ { register Tcl_Obj *valuePtr; - register Tcl_Obj *part1Ptr; - register Tcl_Obj *part2Ptr = NULL; Tcl_Obj *varValuePtr; - int length; /* * Create an object holding the variable's new value and use - * Tcl_ObjSetVar2 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); - length = strlen(part1) ; - TclNewObj(part1Ptr); - TclInitStringRep(part1Ptr, part1, length); - Tcl_IncrRefCount(part1Ptr); - - if (part2 != NULL) { - length = strlen(part2); - TclNewObj(part2Ptr); - TclInitStringRep(part2Ptr, part2, length); - Tcl_IncrRefCount(part2Ptr); - } - - varValuePtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, valuePtr, - flags); - - TclDecrRefCount(part1Ptr); /* done with the part1 name object */ - if (part2Ptr != NULL) { - TclDecrRefCount(part2Ptr); /* and the part2 name object */ - } + varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); Tcl_DecrRefCount(valuePtr); /* done with the object */ if (varValuePtr == NULL) { - /* - * Move the interpreter's object result to the string result, - * then reset the object result. - * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS. - */ - - Tcl_SetResult(interp, - TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL), - TCL_VOLATILE); return NULL; } + return TclGetString(varValuePtr); +} + +/* + *---------------------------------------------------------------------- + * + * 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. - /* - * THIS FAILS IF Tcl_ObjSetVar2's RESULT'S STRING REP HAS A NULL BYTE. - */ + * + *---------------------------------------------------------------------- + */ - return TclGetStringFromObj(varValuePtr, (int *) NULL); +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_ObjSetVar2 -- + * 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 @@ -1160,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_ObjSetVar2. 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. * @@ -1172,40 +1180,27 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) */ Tcl_Obj * -Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) +Tcl_SetVar2Ex(interp, part1, part2, 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. */ + char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ 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. */ + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ { Interp *iPtr = (Interp *) interp; register Var *varPtr; Var *arrayPtr; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - char *part1, *bytes; - char *part2 = NULL; + char *bytes; int length, result; - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - part1 = TclGetStringFromObj(part1Ptr, (int *) NULL); - if (part2Ptr != NULL) { - part2 = TclGetStringFromObj(part2Ptr, (int *) NULL); - } - varPtr = TclLookupVar(interp, part1, part2, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { @@ -1342,7 +1337,7 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_WRITES); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); if (msg != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, "set", msg); @@ -1640,11 +1635,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, } #endif /* TCL_COMPILE_DEBUG */ - /* - * THIS FAILS IF THE ELEMENT NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - elem = Tcl_GetStringFromObj(elemPtr, (int *) NULL); + elem = TclGetString(elemPtr); arrayPtr = &(compiledLocals[localIndex]); arrayName = arrayPtr->name; @@ -1808,7 +1799,7 @@ TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, */ Tcl_Obj * -TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) +TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ Tcl_Obj *part1Ptr; /* Points to an object holding the name of @@ -1818,8 +1809,10 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * the name of an element in the array * part1Ptr. */ long incrAmount; /* Amount to be added to variable. */ - int part1NotParsed; /* 1 if part1 hasn't yet been parsed into - * an array name and index (if any). */ + 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. */ { register Tcl_Obj *varValuePtr; Tcl_Obj *resultPtr; @@ -1827,13 +1820,8 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * so we must increment a copy (i.e. copy * on write). */ long i; - int flags, result; + int result; - flags = TCL_LEAVE_ERR_MSG; - if (part1NotParsed) { - flags |= TCL_PARSE_PART1; - } - varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, @@ -1866,8 +1854,7 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, part1NotParsed) * Store the variable's new value and run any write traces. */ - resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, - flags); + resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); if (resultPtr == NULL) { return NULL; } @@ -2056,7 +2043,7 @@ TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) * 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 interp->result. + * is left in the interp's result. * * Side effects: * If varName is defined as a local or global variable in interp, @@ -2076,8 +2063,7 @@ Tcl_UnsetVar(interp, varName, flags) * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or * TCL_LEAVE_ERR_MSG. */ { - return Tcl_UnsetVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1)); + return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags); } /* @@ -2091,7 +2077,7 @@ Tcl_UnsetVar(interp, varName, flags) * 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 interp->result. + * is left in the interp's result. * * Side effects: * If part1 and part2 indicate a local or global variable in interp, @@ -2109,8 +2095,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_LEAVE_ERR_MSG, or - * TCL_PARSE_PART1. */ + * TCL_LEAVE_ERR_MSG. */ { Var dummyVar; Var *varPtr, *dummyVarPtr; @@ -2166,7 +2151,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; @@ -2265,8 +2250,8 @@ Tcl_TraceVar(interp, varName, flags, proc, clientData) * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { - return Tcl_TraceVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, clientData); + return Tcl_TraceVar2(interp, varName, (char *) NULL, + flags, proc, clientData); } /* @@ -2301,8 +2286,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY and - * TCL_PARSE_PART1. */ + * and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are * invoked upon varName. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ @@ -2324,7 +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); + flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); tracePtr->nextPtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr; return TCL_OK; @@ -2361,8 +2346,7 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { - Tcl_UntraceVar2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, clientData); + Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); } /* @@ -2394,8 +2378,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) * current trace, including any of * TCL_TRACE_READS, TCL_TRACE_WRITES, * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY and - * TCL_PARSE_PART1. */ + * and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData clientData; /* Arbitrary argument to pass to proc. */ { @@ -2406,14 +2389,15 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) ActiveVarTrace *activePtr; varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS); + flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY); for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { @@ -2495,7 +2479,7 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) * first trace. */ { return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, - (flags | TCL_PARSE_PART1), proc, prevClientData); + flags, proc, prevClientData); } /* @@ -2523,8 +2507,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, and - * TCL_PARSE_PART1. */ + * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ ClientData prevClientData; /* If non-NULL, gives last value returned * by this procedure, so this call will @@ -2536,7 +2519,7 @@ Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Var *varPtr, *arrayPtr; varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_PARSE_PART1), + flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { @@ -2599,13 +2582,9 @@ Tcl_UnsetObjCmd(dummy, interp, objc, objv) } for (i = 1; i < objc; i++) { - /* - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. - */ - - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = TclGetString(objv[i]); if (Tcl_UnsetVar2(interp, name, (char *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)) != TCL_OK) { + TCL_LEAVE_ERR_MSG) != TCL_OK) { return TCL_ERROR; } } @@ -2638,32 +2617,28 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { register Tcl_Obj *varValuePtr = NULL; - /* Initialized to avoid compiler - * warning. */ + /* Initialized to avoid compiler + * warning. */ int i; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - if (objc == 2) { - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + 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_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - objv[i], - (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } } } - Tcl_SetObjResult(interp, varValuePtr); return TCL_OK; } @@ -2702,10 +2677,9 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } - if (objc == 2) { newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + (TCL_LEAVE_ERR_MSG)); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty @@ -2714,7 +2688,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) Tcl_Obj *nullObjPtr = Tcl_NewObj(); newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, - nullObjPtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + nullObjPtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ return TCL_ERROR; @@ -2722,7 +2696,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) } } else { /* - * We have arguments to append. We used to call Tcl_ObjSetVar2 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 @@ -2733,8 +2707,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - TCL_PARSE_PART1); + varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet @@ -2742,13 +2715,13 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * create it with Tcl_ObjSetVar2 below. */ - char *name, *p; + char *p, *varName; int nameBytes, i; - name = TclGetStringFromObj(objv[1], &nameBytes); - for (i = 0, p = name; i < nameBytes; i++, p++) { + varName = Tcl_GetStringFromObj(objv[1], &nameBytes); + for (i = 0, p = varName; i < nameBytes; i++, p++) { if (*p == '(') { - p = (name + nameBytes-1); + p = (varName + nameBytes-1); if (*p == ')') { /* last char is ')' => array ref */ createVar = 0; } @@ -2821,8 +2794,8 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - varValuePtr, (TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1)); + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ @@ -2874,14 +2847,15 @@ 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; Tcl_HashEntry *hPtr; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); int notArray; - char *varName; + char *varName, *msg; int index, result; @@ -2890,17 +2864,16 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", + 0, &index) != TCL_OK) { return TCL_ERROR; } /* * Locate the array variable (and it better be an array). - * THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE. */ - varName = TclGetStringFromObj(objv[2], (int *) NULL); + varName = TclGetString(objv[2]); varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); @@ -2909,7 +2882,22 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) || TclIsVarUndefined(varPtr)) { notArray = 1; } - + + /* + * Special array trace used to keep the env array in sync for + * array names, array get, etc. + */ + + if (varPtr != NULL && varPtr->tracePtr != NULL) { + msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY)); + if (msg != NULL) { + VarErrMsg(interp, varName, NULL, "trace array", msg); + return TCL_ERROR; + } + } + switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; @@ -2923,7 +2911,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -2958,7 +2946,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -3000,7 +2988,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_OK; } if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + pattern = TclGetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -3051,7 +3039,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return TCL_OK; } if (objc == 4) { - pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL); + pattern = Tcl_GetString(objv[3]); } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -3067,7 +3055,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name object */ + Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ return result; } } @@ -3086,7 +3074,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL); + searchId = Tcl_GetString(objv[3]); searchPtr = ParseSearchId(interp, varPtr, varName, searchId); if (searchPtr == NULL) { return TCL_ERROR; @@ -3113,73 +3101,11 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) break; } case ARRAY_SET: { - Tcl_Obj **elemPtrs; - int listLen, i, result; - if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); return TCL_ERROR; } - result = Tcl_ListObjGetElements(interp, objv[3], &listLen, - &elemPtrs); - if (result != TCL_OK) { - return result; - } - if (listLen & 1) { - Tcl_ResetResult(interp); - Tcl_AppendToObj(Tcl_GetObjResult(interp), - "list must have an even number of elements", -1); - return TCL_ERROR; - } - if (listLen > 0) { - for (i = 0; i < listLen; i += 2) { - if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], - elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { - result = TCL_ERROR; - break; - } - } - return result; - } - - /* - * The list is empty make sure we have an array, or create - * one if necessary. - */ - - if (varPtr != NULL) { - if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { - /* - * Already an array, done. - */ - - return TCL_OK; - } - if (TclIsVarArrayElement(varPtr) || - !TclIsVarUndefined(varPtr)) { - /* - * Either an array element, or a scalar: lose! - */ - - VarErrMsg(interp, varName, (char *)NULL, "array set", - needArray); - return TCL_ERROR; - } - } else { - /* - * Create variable for new array. - */ - - varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, - /*createPart1*/ 1, /*createPart2*/ 0, - &arrayPtr); - } - TclSetVarArray(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - return TCL_OK; + return(TclArraySet(interp, objv[2], objv[3])); } case ARRAY_SIZE: { Tcl_HashSearch search; @@ -3221,7 +3147,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, (char *) NULL); } else { - char string[20]; + char string[TCL_INTEGER_SPACE]; searchPtr->id = varPtr->searchPtr->id + 1; TclFormatInt(string, searchPtr->id); @@ -3247,6 +3173,102 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * TclArraySet -- + * + * Set the elements of an array. If there are no elements to + * set, create an empty array. This routine is used by the + * Tcl_ArrayObjCmd and by the TclSetupEnv routine. + * + * Results: + * A standard Tcl result object. + * + * Side effects: + * A variable will be created if one does not already exist. + * + *---------------------------------------------------------------------- + */ + +int +TclArraySet(interp, arrayNameObj, arrayElemObj) + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Obj *arrayNameObj; /* The array name. */ + Tcl_Obj *arrayElemObj; /* The array elements list. If this is + * NULL, create an empty array. */ +{ + Var *varPtr, *arrayPtr; + Tcl_Obj **elemPtrs; + int result, elemLen, i; + char *varName; + + varName = TclGetString(arrayNameObj); + varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + if (arrayElemObj != NULL) { + result = Tcl_ListObjGetElements(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + if (elemLen & 1) { + Tcl_ResetResult(interp); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "list must have an even number of elements", -1); + return TCL_ERROR; + } + if (elemLen > 0) { + for (i = 0; i < elemLen; i += 2) { + if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + break; + } + } + return result; + } + } + + /* + * The list is empty make sure we have an array, or create + * one if necessary. + */ + + if (varPtr != NULL) { + if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { + /* + * Already an array, done. + */ + + return TCL_OK; + } + if (TclIsVarArrayElement(varPtr) || + !TclIsVarUndefined(varPtr)) { + /* + * Either an array element, or a scalar: lose! + */ + + VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); + return TCL_ERROR; + } + } else { + /* + * Create variable for new array. + */ + + varPtr = TclLookupVar(interp, varName, (char *) NULL, 0, 0, + /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); + } + TclSetVarArray(varPtr); + TclClearVarUndefined(varPtr); + varPtr->value.tablePtr = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * MakeUpvar -- * * This procedure does all of the work of the "global" and "upvar" @@ -3453,7 +3475,7 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) * * Results: * A standard Tcl completion code. If an error occurs then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by varName becomes @@ -3526,7 +3548,7 @@ Tcl_UpVar(interp, frameName, varName, localName, flags) * * Results: * A standard Tcl completion code. If an error occurs then - * an error message is left in interp->result. + * an error message is left in the interp's result. * * Side effects: * The variable in frameName whose name is given by part1 and @@ -3665,7 +3687,7 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) */ objPtr = objv[i]; - varName = Tcl_GetStringFromObj(objPtr, (int *) NULL); + varName = TclGetString(objPtr); /* * The variable name might have a scope qualifier, but the name for @@ -3750,7 +3772,7 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * it if necessary. */ - varName = Tcl_GetStringFromObj(objv[i], (int *) NULL); + varName = TclGetString(objv[i]); varPtr = TclLookupVar(interp, varName, (char *) NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); @@ -3778,8 +3800,8 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_ObjSetVar2(interp, objv[i], (Tcl_Obj *) NULL, - objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3865,10 +3887,10 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) /* * Find the call frame containing each of the "other variables" to be - * linked to. FAILS IF objv[1]'s STRING REP CONTAINS NULLS. + * linked to. */ - frameSpec = Tcl_GetStringFromObj(objv[1], (int *) NULL); + frameSpec = TclGetString(objv[1]); result = TclGetFrame(interp, frameSpec, &framePtr); if (result == -1) { return TCL_ERROR; @@ -3886,8 +3908,8 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) */ for ( ; objc > 0; objc -= 2, objv += 2) { - myVarName = Tcl_GetStringFromObj(objv[1], (int *) NULL); - otherVarName = Tcl_GetStringFromObj(objv[0], (int *) NULL); + myVarName = TclGetString(objv[1]); + otherVarName = TclGetString(objv[0]); for (p = otherVarName; *p != 0; p++) { if (*p == '(') { char *openParen = p; @@ -3959,9 +3981,7 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and - * TCL_INTERP_DESTROYED. May also contain - * TCL_PARSE_PART1, which should not be - * passed through to callbacks. */ + * TCL_INTERP_DESTROYED. */ { register VarTrace *tracePtr; ActiveVarTrace active; @@ -3990,11 +4010,8 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ copiedName = 0; - if (flags & TCL_PARSE_PART1) { - for (p = part1; ; p++) { - if (*p == 0) { - break; - } + if (part2 == NULL) { + for (p = part1; *p ; p++) { if (*p == '(') { openParen = p; do { @@ -4014,7 +4031,6 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } } } - flags &= ~TCL_PARSE_PART1; /* * Invoke traces on the array containing the variable, if relevant. @@ -4136,7 +4152,7 @@ NewVar() * Results: * The return value is a pointer to the array search indicated * by string, or NULL if there isn't one. If NULL is returned, - * interp->result contains an error message. + * the interp's result contains an error message. * * Side effects: * None. @@ -4316,8 +4332,7 @@ TclDeleteVars(iPtr, tablePtr) Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetStringFromObj(objPtr, (int *) NULL), - (char *) NULL, flags); + Tcl_GetString(objPtr), (char *) NULL, flags); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { @@ -4615,7 +4630,7 @@ CleanupVar(varPtr, arrayPtr) * None. * * Side effects: - * Interp->result is reset to hold a message identifying the + * The interp's result is set to hold a message identifying the * variable given by part1 and part2 and describing why the * variable operation failed. * |