sl@0: /* sl@0: * tclVar.c -- sl@0: * sl@0: * This file contains routines that implement Tcl variables sl@0: * (both scalars and arrays). sl@0: * sl@0: * The implementation of arrays is modelled after an initial sl@0: * implementation by Mark Diekhans and Karl Lehenbauer. sl@0: * sl@0: * Copyright (c) 1987-1994 The Regents of the University of California. sl@0: * Copyright (c) 1994-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclVar.c,v 1.69.2.14 2007/05/10 18:23:58 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: sl@0: sl@0: /* sl@0: * The strings below are used to indicate what went wrong when a sl@0: * variable access is denied. sl@0: */ sl@0: sl@0: static CONST char *noSuchVar = "no such variable"; sl@0: static CONST char *isArray = "variable is array"; sl@0: static CONST char *needArray = "variable isn't array"; sl@0: static CONST char *noSuchElement = "no such element in array"; sl@0: static CONST char *danglingElement = sl@0: "upvar refers to element in deleted array"; sl@0: static CONST char *danglingVar = sl@0: "upvar refers to variable in deleted namespace"; sl@0: static CONST char *badNamespace = "parent namespace doesn't exist"; sl@0: static CONST char *missingName = "missing variable name"; sl@0: static CONST char *isArrayElement = "name refers to an element in an array"; sl@0: sl@0: /* sl@0: * Forward references to procedures defined later in this file: sl@0: */ sl@0: sl@0: static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, sl@0: Var *varPtr, CONST char *part1, CONST char *part2, sl@0: int flags, CONST int leaveErrMsg)); sl@0: static void CleanupVar _ANSI_ARGS_((Var *varPtr, sl@0: Var *arrayPtr)); sl@0: static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); sl@0: static void DeleteArray _ANSI_ARGS_((Interp *iPtr, sl@0: CONST char *arrayName, Var *varPtr, int flags)); sl@0: static void DisposeTraceResult _ANSI_ARGS_((int flags, sl@0: char *result)); sl@0: static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CallFrame *framePtr, Tcl_Obj *otherP1Ptr, sl@0: CONST char *otherP2, CONST int otherFlags, sl@0: CONST char *myName, int myFlags, int index)); sl@0: static Var * NewVar _ANSI_ARGS_((void)); sl@0: static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CONST Var *varPtr, CONST char *varName, sl@0: Tcl_Obj *handleObj)); sl@0: static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CONST char *part1, CONST char *part2, sl@0: CONST char *operation, CONST char *reason)); sl@0: static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static void UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr, sl@0: Interp *iPtr, CONST char *part1, CONST char *part2, sl@0: int flags)); sl@0: sl@0: /* sl@0: * Functions defined in this file that may be exported in the future sl@0: * for use by the bytecode compiler and engine or to the public interface. sl@0: */ sl@0: sl@0: Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp, sl@0: CONST char *varName, int flags, CONST int create, sl@0: CONST char **errMsgPtr, int *indexPtr)); sl@0: int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *part1Ptr, CONST char *part2, int flags)); sl@0: sl@0: static Tcl_FreeInternalRepProc FreeLocalVarName; sl@0: static Tcl_DupInternalRepProc DupLocalVarName; sl@0: static Tcl_UpdateStringProc UpdateLocalVarName; sl@0: static Tcl_FreeInternalRepProc FreeNsVarName; sl@0: static Tcl_DupInternalRepProc DupNsVarName; sl@0: static Tcl_FreeInternalRepProc FreeParsedVarName; sl@0: static Tcl_DupInternalRepProc DupParsedVarName; sl@0: static Tcl_UpdateStringProc UpdateParsedVarName; sl@0: sl@0: /* sl@0: * Types of Tcl_Objs used to cache variable lookups. sl@0: * sl@0: * sl@0: * localVarName - INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1 = pointer to the corresponding Proc sl@0: * twoPtrValue.ptr2 = index into locals table sl@0: * sl@0: * nsVarName - INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1: pointer to the namespace containing the sl@0: * reference sl@0: * twoPtrValue.ptr2: pointer to the corresponding Var sl@0: * sl@0: * parsedVarName - INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, sl@0: * or NULL if it is a scalar variable sl@0: * twoPtrValue.ptr2 = pointer to the element name string sl@0: * (owned by this Tcl_Obj), or NULL if sl@0: * it is a scalar variable sl@0: */ sl@0: sl@0: static Tcl_ObjType tclLocalVarNameType = { sl@0: "localVarName", sl@0: FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL sl@0: }; sl@0: sl@0: static Tcl_ObjType tclNsVarNameType = { sl@0: "namespaceVarName", sl@0: FreeNsVarName, DupNsVarName, NULL, NULL sl@0: }; sl@0: sl@0: static Tcl_ObjType tclParsedVarNameType = { sl@0: "parsedVarName", sl@0: FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL sl@0: }; sl@0: sl@0: /* sl@0: * Type of Tcl_Objs used to speed up array searches. sl@0: * sl@0: * INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL sl@0: * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL sl@0: * sl@0: * Note that the value stored in ptr2 is the offset into the string of sl@0: * the start of the variable name and not the address of the variable sl@0: * name itself, as this can be safely copied. sl@0: */ sl@0: Tcl_ObjType tclArraySearchType = { sl@0: "array search", sl@0: NULL, NULL, NULL, SetArraySearchObj sl@0: }; sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLookupVar -- sl@0: * sl@0: * This procedure is used to locate a variable given its name(s). It sl@0: * has been mostly superseded by TclObjLookupVar, it is now only used sl@0: * by the string-based interfaces. It is kept in tcl8.4 mainly because sl@0: * it is in the internal stubs table, so that some extension may be sl@0: * calling it. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the variable structure indicated by sl@0: * part1 and part2, or NULL if the variable couldn't be found. If the sl@0: * variable is found, *arrayPtrPtr is filled in with the address of the sl@0: * variable structure for the array that contains the variable (or NULL sl@0: * if the variable is a scalar). If the variable can't be found and sl@0: * either createPart1 or createPart2 are 1, a new as-yet-undefined sl@0: * (VAR_UNDEFINED) variable structure is created, entered into a hash sl@0: * table, and returned. sl@0: * sl@0: * If the variable isn't found and creation wasn't specified, or some sl@0: * other error occurs, NULL is returned and an error message is left in sl@0: * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. sl@0: * sl@0: * Note: it's possible for the variable returned to be VAR_UNDEFINED sl@0: * even if createPart1 or createPart2 are 1 (these only cause the hash sl@0: * table entry or array to be created). For example, the variable might sl@0: * be a global that has been unset but is still referenced by a sl@0: * procedure, or a variable that has been unset but it only being kept sl@0: * in existence (if VAR_UNDEFINED) by a trace. sl@0: * sl@0: * Side effects: sl@0: * New hashtable entries may be created if createPart1 or createPart2 sl@0: * are 1. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: Var * sl@0: TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, sl@0: arrayPtrPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for lookup. */ sl@0: CONST char *part1; /* If part2 isn't NULL, this is the name of sl@0: * an array. Otherwise, this sl@0: * is a full variable name that could sl@0: * include a parenthesized array element. */ sl@0: CONST char *part2; /* Name of element within array, or NULL. */ sl@0: int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * and TCL_LEAVE_ERR_MSG bits matter. */ sl@0: CONST char *msg; /* Verb to use in error messages, e.g. sl@0: * "read" or "set". Only needed if sl@0: * TCL_LEAVE_ERR_MSG is set in flags. */ sl@0: int createPart1; /* If 1, create hash table entry for part 1 sl@0: * of name, if it doesn't already exist. If sl@0: * 0, return error if it doesn't exist. */ sl@0: int createPart2; /* If 1, create hash table entry for part 2 sl@0: * of name, if it doesn't already exist. If sl@0: * 0, return error if it doesn't exist. */ sl@0: Var **arrayPtrPtr; /* If the name refers to an element of an sl@0: * array, *arrayPtrPtr gets filled in with sl@0: * address of array variable. Otherwise sl@0: * this is set to NULL. */ sl@0: { sl@0: Var *varPtr; sl@0: CONST char *elName; /* Name of array element or NULL; may be sl@0: * same as part2, or may be openParen+1. */ sl@0: int openParen, closeParen; sl@0: /* If this procedure parses a name into sl@0: * array and index, these are the offsets to sl@0: * the parens around the index. Otherwise sl@0: * they are -1. */ sl@0: register CONST char *p; sl@0: CONST char *errMsg = NULL; sl@0: int index; sl@0: #define VAR_NAME_BUF_SIZE 26 sl@0: char buffer[VAR_NAME_BUF_SIZE]; sl@0: char *newVarName = buffer; sl@0: sl@0: varPtr = NULL; sl@0: *arrayPtrPtr = NULL; sl@0: openParen = closeParen = -1; sl@0: sl@0: /* sl@0: * Parse part1 into array name and index. sl@0: * Always check if part1 is an array element name and allow it only if sl@0: * part2 is not given. sl@0: * (if one does not care about creating array elements that can't be used sl@0: * from tcl, and prefer slightly better performance, one can put sl@0: * the following in an if (part2 == NULL) { ... } block and remove sl@0: * the part2's test and error reporting or move that code in array set) sl@0: */ sl@0: sl@0: elName = part2; sl@0: for (p = part1; *p ; p++) { sl@0: if (*p == '(') { sl@0: openParen = p - part1; sl@0: do { sl@0: p++; sl@0: } while (*p != '\0'); sl@0: p--; sl@0: if (*p == ')') { sl@0: if (part2 != NULL) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, part1, part2, msg, needArray); sl@0: } sl@0: return NULL; sl@0: } sl@0: closeParen = p - part1; sl@0: } else { sl@0: openParen = -1; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: if (openParen != -1) { sl@0: if (closeParen >= VAR_NAME_BUF_SIZE) { sl@0: newVarName = ckalloc((unsigned int) (closeParen+1)); sl@0: } sl@0: memcpy(newVarName, part1, (unsigned int) closeParen); sl@0: newVarName[openParen] = '\0'; sl@0: newVarName[closeParen] = '\0'; sl@0: part1 = newVarName; sl@0: elName = newVarName + openParen + 1; sl@0: } sl@0: sl@0: varPtr = TclLookupSimpleVar(interp, part1, flags, sl@0: createPart1, &errMsg, &index); sl@0: if (varPtr == NULL) { sl@0: if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { sl@0: VarErrMsg(interp, part1, elName, msg, errMsg); sl@0: } sl@0: } else { sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: if (elName != NULL) { sl@0: *arrayPtrPtr = varPtr; sl@0: varPtr = TclLookupArrayElement(interp, part1, elName, flags, sl@0: msg, createPart1, createPart2, varPtr); sl@0: } sl@0: } sl@0: if (newVarName != buffer) { sl@0: ckfree(newVarName); sl@0: } sl@0: sl@0: return varPtr; sl@0: sl@0: #undef VAR_NAME_BUF_SIZE sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclObjLookupVar -- sl@0: * sl@0: * This procedure is used by virtually all of the variable code to sl@0: * locate a variable given its name(s). The parsing into array/element sl@0: * components and (if possible) the lookup results are cached in sl@0: * part1Ptr, which is converted to one of the varNameTypes. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the variable structure indicated by sl@0: * part1Ptr and part2, or NULL if the variable couldn't be found. If sl@0: * the variable is found, *arrayPtrPtr is filled with the address of the sl@0: * variable structure for the array that contains the variable (or NULL sl@0: * if the variable is a scalar). If the variable can't be found and sl@0: * either createPart1 or createPart2 are 1, a new as-yet-undefined sl@0: * (VAR_UNDEFINED) variable structure is created, entered into a hash sl@0: * table, and returned. sl@0: * sl@0: * If the variable isn't found and creation wasn't specified, or some sl@0: * other error occurs, NULL is returned and an error message is left in sl@0: * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. sl@0: * sl@0: * Note: it's possible for the variable returned to be VAR_UNDEFINED sl@0: * even if createPart1 or createPart2 are 1 (these only cause the hash sl@0: * table entry or array to be created). For example, the variable might sl@0: * be a global that has been unset but is still referenced by a sl@0: * procedure, or a variable that has been unset but it only being kept sl@0: * in existence (if VAR_UNDEFINED) by a trace. sl@0: * sl@0: * Side effects: sl@0: * New hashtable entries may be created if createPart1 or createPart2 sl@0: * are 1. sl@0: * The object part1Ptr is converted to one of tclLocalVarNameType, sl@0: * tclNsVarNameType or tclParsedVarNameType and caches as much of the sl@0: * lookup as it can. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: Var * sl@0: TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2, sl@0: arrayPtrPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for lookup. */ sl@0: register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name sl@0: * of an array. Otherwise, this is a full sl@0: * variable name that could include a parenthesized sl@0: * array element. */ sl@0: CONST char *part2; /* Name of element within array, or NULL. */ sl@0: int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * and TCL_LEAVE_ERR_MSG bits matter. */ sl@0: CONST char *msg; /* Verb to use in error messages, e.g. sl@0: * "read" or "set". Only needed if sl@0: * TCL_LEAVE_ERR_MSG is set in flags. */ sl@0: CONST int createPart1; /* If 1, create hash table entry for part 1 sl@0: * of name, if it doesn't already exist. If sl@0: * 0, return error if it doesn't exist. */ sl@0: CONST int createPart2; /* If 1, create hash table entry for part 2 sl@0: * of name, if it doesn't already exist. If sl@0: * 0, return error if it doesn't exist. */ sl@0: Var **arrayPtrPtr; /* If the name refers to an element of an sl@0: * array, *arrayPtrPtr gets filled in with sl@0: * address of array variable. Otherwise sl@0: * this is set to NULL. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register Var *varPtr; /* Points to the variable's in-frame Var sl@0: * structure. */ sl@0: char *part1; sl@0: int index, len1, len2; sl@0: int parsed = 0; sl@0: Tcl_Obj *objPtr; sl@0: Tcl_ObjType *typePtr = part1Ptr->typePtr; sl@0: CONST char *errMsg = NULL; sl@0: CallFrame *varFramePtr = iPtr->varFramePtr; sl@0: Namespace *nsPtr; sl@0: sl@0: /* sl@0: * If part1Ptr is a tclParsedVarNameType, separate it into the sl@0: * pre-parsed parts. sl@0: */ sl@0: sl@0: *arrayPtrPtr = NULL; sl@0: if (typePtr == &tclParsedVarNameType) { sl@0: if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { sl@0: if (part2 != NULL) { sl@0: /* sl@0: * ERROR: part1Ptr is already an array element, cannot sl@0: * specify a part2. sl@0: */ sl@0: sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: part1 = TclGetString(part1Ptr); sl@0: VarErrMsg(interp, part1, part2, msg, needArray); sl@0: } sl@0: return NULL; sl@0: } sl@0: part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2; sl@0: part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1; sl@0: typePtr = part1Ptr->typePtr; sl@0: } sl@0: parsed = 1; sl@0: } sl@0: part1 = Tcl_GetStringFromObj(part1Ptr, &len1); sl@0: sl@0: nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr); sl@0: if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { sl@0: goto doParse; sl@0: } sl@0: sl@0: if (typePtr == &tclLocalVarNameType) { sl@0: Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1; sl@0: int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2; sl@0: int useLocal; sl@0: sl@0: useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame sl@0: && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))); sl@0: if (useLocal && (procPtr == varFramePtr->procPtr)) { sl@0: /* sl@0: * part1Ptr points to an indexed local variable of the sl@0: * correct procedure: use the cached value. sl@0: */ sl@0: sl@0: varPtr = &(varFramePtr->compiledLocals[localIndex]); sl@0: goto donePart1; sl@0: } sl@0: goto doneParsing; sl@0: } else if (typePtr == &tclNsVarNameType) { sl@0: Namespace *cachedNsPtr; sl@0: int useGlobal, useReference; sl@0: sl@0: varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; sl@0: cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1; sl@0: useGlobal = (cachedNsPtr == iPtr->globalNsPtr) sl@0: && ((flags & TCL_GLOBAL_ONLY) sl@0: || ((*part1 == ':') && (*(part1+1) == ':')) sl@0: || (varFramePtr == NULL) sl@0: || (!varFramePtr->isProcCallFrame sl@0: && (nsPtr == iPtr->globalNsPtr))); sl@0: useReference = useGlobal || ((cachedNsPtr == nsPtr) sl@0: && ((flags & TCL_NAMESPACE_ONLY) sl@0: || (varFramePtr && !varFramePtr->isProcCallFrame sl@0: && !(flags & TCL_GLOBAL_ONLY) sl@0: /* careful: an undefined ns variable could sl@0: * be hiding a valid global reference. */ sl@0: && !(varPtr->flags & VAR_UNDEFINED)))); sl@0: if (useReference && (varPtr->hPtr != NULL)) { sl@0: /* sl@0: * A straight global or namespace reference, use it. It isn't sl@0: * so simple to deal with 'implicit' namespace references, i.e., sl@0: * those where the reference could be to either a namespace sl@0: * or a global variable. Those we lookup again. sl@0: * sl@0: * If (varPtr->hPtr == NULL), this might be a reference to a sl@0: * variable in a deleted namespace, kept alive by e.g. part1Ptr. sl@0: * We could conceivably be so unlucky that a new namespace was sl@0: * created at the same address as the deleted one, so to be sl@0: * safe we test for a valid hPtr. sl@0: */ sl@0: goto donePart1; sl@0: } sl@0: goto doneParsing; sl@0: } sl@0: sl@0: doParse: sl@0: if (!parsed && (*(part1 + len1 - 1) == ')')) { sl@0: /* sl@0: * part1Ptr is possibly an unparsed array element. sl@0: */ sl@0: register int i; sl@0: char *newPart2; sl@0: len2 = -1; sl@0: for (i = 0; i < len1; i++) { sl@0: if (*(part1 + i) == '(') { sl@0: if (part2 != NULL) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, part1, part2, msg, needArray); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * part1Ptr points to an array element; first copy sl@0: * the element name to a new string part2. sl@0: */ sl@0: sl@0: part2 = part1 + i + 1; sl@0: len2 = len1 - i - 2; sl@0: len1 = i; sl@0: sl@0: newPart2 = ckalloc((unsigned int) (len2+1)); sl@0: memcpy(newPart2, part2, (unsigned int) len2); sl@0: *(newPart2+len2) = '\0'; sl@0: part2 = newPart2; sl@0: sl@0: /* sl@0: * Free the internal rep of the original part1Ptr, now sl@0: * renamed objPtr, and set it to tclParsedVarNameType. sl@0: */ sl@0: sl@0: objPtr = part1Ptr; sl@0: if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { sl@0: typePtr->freeIntRepProc(objPtr); sl@0: } sl@0: objPtr->typePtr = &tclParsedVarNameType; sl@0: sl@0: /* sl@0: * Define a new string object to hold the new part1Ptr, i.e., sl@0: * the array name. Set the internal rep of objPtr, reset sl@0: * typePtr and part1 to contain the references to the sl@0: * array name. sl@0: */ sl@0: sl@0: part1Ptr = Tcl_NewStringObj(part1, len1); sl@0: Tcl_IncrRefCount(part1Ptr); sl@0: sl@0: objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr; sl@0: objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2; sl@0: sl@0: typePtr = part1Ptr->typePtr; sl@0: part1 = TclGetString(part1Ptr); sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: doneParsing: sl@0: /* sl@0: * part1Ptr is not an array element; look it up, and convert sl@0: * it to one of the cached types if possible. sl@0: */ sl@0: sl@0: if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { sl@0: typePtr->freeIntRepProc(part1Ptr); sl@0: part1Ptr->typePtr = NULL; sl@0: } sl@0: sl@0: varPtr = TclLookupSimpleVar(interp, part1, flags, sl@0: createPart1, &errMsg, &index); sl@0: if (varPtr == NULL) { sl@0: if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { sl@0: VarErrMsg(interp, part1, part2, msg, errMsg); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Cache the newly found variable if possible. sl@0: */ sl@0: sl@0: if (index >= 0) { sl@0: /* sl@0: * An indexed local variable. sl@0: */ sl@0: sl@0: Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr; sl@0: sl@0: part1Ptr->typePtr = &tclLocalVarNameType; sl@0: procPtr->refCount++; sl@0: part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; sl@0: part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index; sl@0: #if 0 sl@0: /* sl@0: * TEMPORARYLY DISABLED tclNsVarNameType sl@0: * sl@0: * This optimisation will hopefully be turned back on soon. sl@0: * Miguel Sofer, 2004-05-22 sl@0: */ sl@0: sl@0: } else if (index > -3) { sl@0: /* sl@0: * A cacheable namespace or global variable. sl@0: */ sl@0: Namespace *nsPtr; sl@0: sl@0: nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr); sl@0: varPtr->refCount++; sl@0: part1Ptr->typePtr = &tclNsVarNameType; sl@0: part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; sl@0: part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; sl@0: #endif sl@0: } else { sl@0: /* sl@0: * At least mark part1Ptr as already parsed. sl@0: */ sl@0: part1Ptr->typePtr = &tclParsedVarNameType; sl@0: part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; sl@0: part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; sl@0: } sl@0: sl@0: donePart1: sl@0: #if 0 sl@0: if (varPtr == NULL) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: part1 = TclGetString(part1Ptr); sl@0: VarErrMsg(interp, part1, part2, msg, sl@0: "Cached variable reference is NULL."); sl@0: } sl@0: return NULL; sl@0: } sl@0: #endif sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: sl@0: if (part2 != NULL) { sl@0: /* sl@0: * Array element sought: look it up. sl@0: */ sl@0: sl@0: part1 = TclGetString(part1Ptr); sl@0: *arrayPtrPtr = varPtr; sl@0: varPtr = TclLookupArrayElement(interp, part1, part2, sl@0: flags, msg, createPart1, createPart2, varPtr); sl@0: } sl@0: return varPtr; sl@0: } sl@0: sl@0: /* sl@0: * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for sl@0: * upvar (or similar) purposes, with slightly different rules: sl@0: * - Bug #696893 - variable is either proc-local or in the current sl@0: * namespace; never follow the second (global) resolution path sl@0: * - Bug #631741 - do not use special namespace or interp resolvers sl@0: */ sl@0: #define LOOKUP_FOR_UPVAR 0x40000 sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLookupSimpleVar -- sl@0: * sl@0: * This procedure is used by to locate a simple variable (i.e., not sl@0: * an array element) given its name. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the variable structure indicated by sl@0: * varName, or NULL if the variable couldn't be found. If the variable sl@0: * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) sl@0: * variable structure is created, entered into a hash table, and returned. sl@0: * sl@0: * If the current CallFrame corresponds to a proc and the variable found is sl@0: * one of the compiledLocals, its index is placed in *indexPtr. Otherwise, sl@0: * *indexPtr will be set to (according to the needs of TclObjLookupVar): sl@0: * -1 a global reference sl@0: * -2 a reference to a namespace variable sl@0: * -3 a non-cachable reference, i.e., one of: sl@0: * . non-indexed local var sl@0: * . a reference of unknown origin; sl@0: * . resolution by a namespace or interp resolver sl@0: * sl@0: * If the variable isn't found and creation wasn't specified, or some sl@0: * other error occurs, NULL is returned and the corresponding error sl@0: * message is left in *errMsgPtr. sl@0: * sl@0: * Note: it's possible for the variable returned to be VAR_UNDEFINED sl@0: * even if create is 1 (this only causes the hash table entry to be sl@0: * created). For example, the variable might be a global that has been sl@0: * unset but is still referenced by a procedure, or a variable that has sl@0: * been unset but it only being kept in existence (if VAR_UNDEFINED) by sl@0: * a trace. sl@0: * sl@0: * Side effects: sl@0: * A new hashtable entry may be created if create is 1. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Var * sl@0: TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for lookup. */ sl@0: CONST char *varName; /* This is a simple variable name that could sl@0: * representa scalar or an array. */ sl@0: int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits sl@0: * matter. */ sl@0: CONST int create; /* If 1, create hash table entry for varname, sl@0: * if it doesn't already exist. If 0, return sl@0: * error if it doesn't exist. */ sl@0: CONST char **errMsgPtr; sl@0: int *indexPtr; sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CallFrame *varFramePtr = iPtr->varFramePtr; sl@0: /* Points to the procedure call frame whose sl@0: * variables are currently in use. Same as sl@0: * the current procedure's frame, if any, sl@0: * unless an "uplevel" is executing. */ sl@0: Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which sl@0: * to look up the variable. */ sl@0: Tcl_Var var; /* Used to search for global names. */ sl@0: Var *varPtr; /* Points to the Var structure returned for sl@0: * the variable. */ sl@0: Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; sl@0: ResolverScheme *resPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: int new, i, result; sl@0: sl@0: varPtr = NULL; sl@0: varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ sl@0: *indexPtr = -3; sl@0: sl@0: if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) { sl@0: cxtNsPtr = iPtr->globalNsPtr; sl@0: } else { sl@0: cxtNsPtr = iPtr->varFramePtr->nsPtr; sl@0: } sl@0: sl@0: /* sl@0: * If this namespace has a variable resolver, then give it first sl@0: * crack at the variable resolution. It may return a Tcl_Var sl@0: * value, it may signal to continue onward, or it may signal sl@0: * an error. sl@0: */ sl@0: sl@0: if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) sl@0: && !(flags & LOOKUP_FOR_UPVAR)) { sl@0: resPtr = iPtr->resolverPtr; sl@0: sl@0: if (cxtNsPtr->varResProc) { sl@0: result = (*cxtNsPtr->varResProc)(interp, varName, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &var); sl@0: } else { sl@0: result = TCL_CONTINUE; sl@0: } sl@0: sl@0: while (result == TCL_CONTINUE && resPtr) { sl@0: if (resPtr->varResProc) { sl@0: result = (*resPtr->varResProc)(interp, varName, sl@0: (Tcl_Namespace *) cxtNsPtr, flags, &var); sl@0: } sl@0: resPtr = resPtr->nextPtr; sl@0: } sl@0: sl@0: if (result == TCL_OK) { sl@0: varPtr = (Var *) var; sl@0: return varPtr; sl@0: } else if (result != TCL_CONTINUE) { sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Look up varName. Look it up as either a namespace variable or as a sl@0: * local variable in a procedure call frame (varFramePtr). sl@0: * Interpret varName as a namespace variable if: sl@0: * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, sl@0: * 2) there is no active frame (we're at the global :: scope), sl@0: * 3) the active frame was pushed to define the namespace context sl@0: * for a "namespace eval" or "namespace inscope" command, sl@0: * 4) the name has namespace qualifiers ("::"s). sl@0: * Otherwise, if varName is a local variable, search first in the sl@0: * frame's array of compiler-allocated local variables, then in its sl@0: * hashtable for runtime-created local variables. sl@0: * sl@0: * If create and the variable isn't found, create the variable and, sl@0: * if necessary, create varFramePtr's local var hashtable. sl@0: */ sl@0: sl@0: if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) sl@0: || (varFramePtr == NULL) sl@0: || !varFramePtr->isProcCallFrame sl@0: || (strstr(varName, "::") != NULL)) { sl@0: CONST char *tail; sl@0: int lookGlobal; sl@0: sl@0: lookGlobal = (flags & TCL_GLOBAL_ONLY) sl@0: || (cxtNsPtr == iPtr->globalNsPtr) sl@0: || ((*varName == ':') && (*(varName+1) == ':')); sl@0: if (lookGlobal) { sl@0: *indexPtr = -1; sl@0: flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR); sl@0: } else { sl@0: if (flags & LOOKUP_FOR_UPVAR) { sl@0: flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR; sl@0: } sl@0: if (flags & TCL_NAMESPACE_ONLY) { sl@0: *indexPtr = -2; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, sl@0: * or otherwise generate our own error! sl@0: */ sl@0: var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, sl@0: flags & ~TCL_LEAVE_ERR_MSG); sl@0: if (var != (Tcl_Var) NULL) { sl@0: varPtr = (Var *) var; sl@0: } sl@0: if (varPtr == NULL) { sl@0: if (create) { /* var wasn't found so create it */ sl@0: TclGetNamespaceForQualName(interp, varName, cxtNsPtr, sl@0: flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); sl@0: if (varNsPtr == NULL) { sl@0: *errMsgPtr = badNamespace; sl@0: return NULL; sl@0: } sl@0: if (tail == NULL) { sl@0: *errMsgPtr = missingName; sl@0: return NULL; sl@0: } sl@0: hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new); sl@0: varPtr = NewVar(); sl@0: Tcl_SetHashValue(hPtr, varPtr); sl@0: varPtr->hPtr = hPtr; sl@0: varPtr->nsPtr = varNsPtr; sl@0: if ((lookGlobal) || (varNsPtr == NULL)) { sl@0: /* sl@0: * The variable was created starting from the global sl@0: * namespace: a global reference is returned even if sl@0: * it wasn't explicitly requested. sl@0: */ sl@0: *indexPtr = -1; sl@0: } else { sl@0: *indexPtr = -2; sl@0: } sl@0: } else { /* var wasn't found and not to create it */ sl@0: *errMsgPtr = noSuchVar; sl@0: return NULL; sl@0: } sl@0: } sl@0: } else { /* local var: look in frame varFramePtr */ sl@0: Proc *procPtr = varFramePtr->procPtr; sl@0: int localCt = procPtr->numCompiledLocals; sl@0: CompiledLocal *localPtr = procPtr->firstLocalPtr; sl@0: Var *localVarPtr = varFramePtr->compiledLocals; sl@0: int varNameLen = strlen(varName); sl@0: sl@0: for (i = 0; i < localCt; i++) { sl@0: if (!TclIsVarTemporary(localPtr)) { sl@0: register char *localName = localVarPtr->name; sl@0: if ((varName[0] == localName[0]) sl@0: && (varNameLen == localPtr->nameLength) sl@0: && (strcmp(varName, localName) == 0)) { sl@0: *indexPtr = i; sl@0: return localVarPtr; sl@0: } sl@0: } sl@0: localVarPtr++; sl@0: localPtr = localPtr->nextPtr; sl@0: } sl@0: tablePtr = varFramePtr->varTablePtr; sl@0: if (create) { sl@0: if (tablePtr == NULL) { sl@0: tablePtr = (Tcl_HashTable *) sl@0: ckalloc(sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); sl@0: varFramePtr->varTablePtr = tablePtr; sl@0: } sl@0: hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new); sl@0: if (new) { sl@0: varPtr = NewVar(); sl@0: Tcl_SetHashValue(hPtr, varPtr); sl@0: varPtr->hPtr = hPtr; sl@0: varPtr->nsPtr = NULL; /* a local variable */ sl@0: } else { sl@0: varPtr = (Var *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: } else { sl@0: hPtr = NULL; sl@0: if (tablePtr != NULL) { sl@0: hPtr = Tcl_FindHashEntry(tablePtr, varName); sl@0: } sl@0: if (hPtr == NULL) { sl@0: *errMsgPtr = noSuchVar; sl@0: return NULL; sl@0: } sl@0: varPtr = (Var *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: } sl@0: return varPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLookupArrayElement -- sl@0: * sl@0: * This procedure is used to locate a variable which is in an array's sl@0: * hashtable given a pointer to the array's Var structure and the sl@0: * element's name. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the variable structure , or NULL if sl@0: * the variable couldn't be found. sl@0: * sl@0: * If arrayPtr points to a variable that isn't an array and createPart1 sl@0: * is 1, the corresponding variable will be converted to an array. sl@0: * Otherwise, NULL is returned and an error message is left in sl@0: * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. sl@0: * sl@0: * If the variable is not found and createPart2 is 1, the variable is sl@0: * created. Otherwise, NULL is returned and an error message is left in sl@0: * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. sl@0: * sl@0: * Note: it's possible for the variable returned to be VAR_UNDEFINED sl@0: * even if createPart1 or createPart2 are 1 (these only cause the hash sl@0: * table entry or array to be created). For example, the variable might sl@0: * be a global that has been unset but is still referenced by a sl@0: * procedure, or a variable that has been unset but it only being kept sl@0: * in existence (if VAR_UNDEFINED) by a trace. sl@0: * sl@0: * Side effects: sl@0: * The variable at arrayPtr may be converted to be an array if sl@0: * createPart1 is 1. A new hashtable entry may be created if createPart2 sl@0: * is 1. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Var * sl@0: TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for lookup. */ sl@0: CONST char *arrayName; /* This is the name of the array. */ sl@0: CONST char *elName; /* Name of element within array. */ sl@0: CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */ sl@0: CONST char *msg; /* Verb to use in error messages, e.g. sl@0: * "read" or "set". Only needed if sl@0: * TCL_LEAVE_ERR_MSG is set in flags. */ sl@0: CONST int createArray; /* If 1, transform arrayName to be an array sl@0: * if it isn't one yet and the transformation sl@0: * is possible. If 0, return error if it sl@0: * isn't already an array. */ sl@0: CONST int createElem; /* If 1, create hash table entry for the sl@0: * element, if it doesn't already exist. If sl@0: * 0, return error if it doesn't exist. */ sl@0: Var *arrayPtr; /* Pointer to the array's Var structure. */ sl@0: { sl@0: Tcl_HashEntry *hPtr; sl@0: int new; sl@0: Var *varPtr; sl@0: sl@0: /* sl@0: * We're dealing with an array element. Make sure the variable is an sl@0: * array and look up the element (create the element if desired). sl@0: */ sl@0: sl@0: if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { sl@0: if (!createArray) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, arrayName, elName, msg, noSuchVar); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Make sure we are not resurrecting a namespace variable from a sl@0: * deleted namespace! sl@0: */ sl@0: if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, arrayName, elName, msg, danglingVar); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: TclSetVarArray(arrayPtr); sl@0: TclClearVarUndefined(arrayPtr); sl@0: arrayPtr->value.tablePtr = sl@0: (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); sl@0: } else if (!TclIsVarArray(arrayPtr)) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, arrayName, elName, msg, needArray); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: if (createElem) { sl@0: hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new); sl@0: if (new) { sl@0: if (arrayPtr->searchPtr != NULL) { sl@0: DeleteSearches(arrayPtr); sl@0: } sl@0: varPtr = NewVar(); sl@0: Tcl_SetHashValue(hPtr, varPtr); sl@0: varPtr->hPtr = hPtr; sl@0: varPtr->nsPtr = arrayPtr->nsPtr; sl@0: TclSetVarArrayElement(varPtr); sl@0: } sl@0: } else { sl@0: hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName); sl@0: if (hPtr == NULL) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, arrayName, elName, msg, noSuchElement); sl@0: } sl@0: return NULL; sl@0: } sl@0: } sl@0: return (Var *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetVar -- sl@0: * sl@0: * Return the value of a Tcl variable as a string. sl@0: * sl@0: * Results: sl@0: * The return value points to the current value of varName as a string. sl@0: * If the variable is not defined or can't be read because of a clash sl@0: * in array usage then a NULL pointer is returned and an error message sl@0: * is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. sl@0: * Note: the return value is only valid up until the next change to the sl@0: * variable; if you depend on the value lasting longer than that, then sl@0: * make yourself a private copy. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_GetVar(interp, varName, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: CONST char *varName; /* Name of a variable in interp. */ sl@0: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG sl@0: * bits. */ sl@0: { sl@0: return Tcl_GetVar2(interp, varName, (char *) NULL, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetVar2 -- sl@0: * sl@0: * Return the value of a Tcl variable as a string, given a two-part sl@0: * name consisting of array name and element within array. sl@0: * sl@0: * Results: sl@0: * The return value points to the current value of the variable given sl@0: * by part1 and part2 as a string. If the specified variable doesn't sl@0: * exist, or if there is a clash in array usage, then NULL is returned sl@0: * and a message will be left in the interp's result if the sl@0: * TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid sl@0: * up until the next change to the variable; if you depend on the value sl@0: * lasting longer than that, then make yourself a private copy. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_GetVar2(interp, part1, part2, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: CONST char *part1; /* Name of an array (if part2 is non-NULL) sl@0: * or the name of a variable. */ sl@0: CONST char *part2; /* If non-NULL, gives the name of an element sl@0: * in the array part1. */ sl@0: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG sl@0: * bits. */ sl@0: { sl@0: Tcl_Obj *objPtr; sl@0: sl@0: objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags); sl@0: if (objPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: return TclGetString(objPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetVar2Ex -- sl@0: * sl@0: * Return the value of a Tcl variable as a Tcl object, given a sl@0: * two-part name consisting of array name and element within array. sl@0: * sl@0: * Results: sl@0: * The return value points to the current object value of the variable sl@0: * given by part1Ptr and part2Ptr. If the specified variable doesn't sl@0: * exist, or if there is a clash in array usage, then NULL is returned sl@0: * and a message will be left in the interpreter's result if the sl@0: * TCL_LEAVE_ERR_MSG flag is set. sl@0: * sl@0: * Side effects: sl@0: * The ref count for the returned object is _not_ incremented to sl@0: * reflect the returned reference; if you want to keep a reference to sl@0: * the object you must increment its ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_GetVar2Ex(interp, part1, part2, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: CONST char *part1; /* Name of an array (if part2 is non-NULL) sl@0: * or the name of a variable. */ sl@0: CONST char *part2; /* If non-NULL, gives the name of an element sl@0: * in the array part1. */ sl@0: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * and TCL_LEAVE_ERR_MSG bits. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: sl@0: /* Filter to pass through only the flags this interface supports. */ sl@0: flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); sl@0: varPtr = TclLookupVar(interp, part1, part2, flags, "read", sl@0: /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ObjGetVar2 -- sl@0: * sl@0: * Return the value of a Tcl variable as a Tcl object, given a sl@0: * two-part name consisting of array name and element within array. sl@0: * sl@0: * Results: sl@0: * The return value points to the current object value of the variable sl@0: * given by part1Ptr and part2Ptr. If the specified variable doesn't sl@0: * exist, or if there is a clash in array usage, then NULL is returned sl@0: * and a message will be left in the interpreter's result if the sl@0: * TCL_LEAVE_ERR_MSG flag is set. sl@0: * sl@0: * Side effects: sl@0: * The ref count for the returned object is _not_ incremented to sl@0: * reflect the returned reference; if you want to keep a reference to sl@0: * the object you must increment its ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: register Tcl_Obj *part1Ptr; /* Points to an object holding the name of sl@0: * an array (if part2 is non-NULL) or the sl@0: * name of a variable. */ sl@0: register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding sl@0: * the name of an element in the array sl@0: * part1Ptr. */ sl@0: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and sl@0: * TCL_LEAVE_ERR_MSG bits. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: char *part1, *part2; sl@0: sl@0: part1 = Tcl_GetString(part1Ptr); sl@0: part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); sl@0: sl@0: /* Filter to pass through only the flags this interface supports. */ sl@0: flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); sl@0: varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", sl@0: /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclPtrGetVar -- sl@0: * sl@0: * Return the value of a Tcl variable as a Tcl object, given the sl@0: * pointers to the variable's (and possibly containing array's) sl@0: * VAR structure. sl@0: * sl@0: * Results: sl@0: * The return value points to the current object value of the variable sl@0: * given by varPtr. If the specified variable doesn't exist, or if there sl@0: * is a clash in array usage, then NULL is returned and a message will be sl@0: * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. sl@0: * sl@0: * Side effects: sl@0: * The ref count for the returned object is _not_ incremented to sl@0: * reflect the returned reference; if you want to keep a reference to sl@0: * the object you must increment its ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: register Var *varPtr; /* The variable to be read.*/ sl@0: Var *arrayPtr; /* NULL for scalar variables, pointer to sl@0: * the containing array otherwise. */ sl@0: CONST char *part1; /* Name of an array (if part2 is non-NULL) sl@0: * or the name of a variable. */ sl@0: CONST char *part2; /* If non-NULL, gives the name of an element sl@0: * in the array part1. */ sl@0: CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * and TCL_LEAVE_ERR_MSG bits. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CONST char *msg; sl@0: sl@0: /* sl@0: * Invoke any traces that have been set for the variable. sl@0: */ sl@0: sl@0: if ((varPtr->tracePtr != NULL) sl@0: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { sl@0: if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, sl@0: (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) sl@0: | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { sl@0: goto errorReturn; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Return the element if it's an existing scalar variable. sl@0: */ sl@0: sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { sl@0: return varPtr->value.objPtr; sl@0: } sl@0: sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) sl@0: && !TclIsVarUndefined(arrayPtr)) { sl@0: msg = noSuchElement; sl@0: } else if (TclIsVarArray(varPtr)) { sl@0: msg = isArray; sl@0: } else { sl@0: msg = noSuchVar; sl@0: } sl@0: VarErrMsg(interp, part1, part2, "read", msg); sl@0: } sl@0: sl@0: /* sl@0: * An error. If the variable doesn't exist anymore and no-one's using sl@0: * it, then free up the relevant structures and hash table entries. sl@0: */ sl@0: sl@0: errorReturn: sl@0: if (TclIsVarUndefined(varPtr)) { sl@0: CleanupVar(varPtr, arrayPtr); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetObjCmd -- sl@0: * sl@0: * This procedure is invoked to process the "set" Tcl command. sl@0: * See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result value. sl@0: * sl@0: * Side effects: sl@0: * A variable's value may be changed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_SetObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: register Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Obj *varValueObj; sl@0: sl@0: if (objc == 2) { sl@0: varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); sl@0: if (varValueObj == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, varValueObj); sl@0: return TCL_OK; sl@0: } else if (objc == 3) { sl@0: sl@0: varValueObj = Tcl_ObjSetVar2(interp, objv[1], NULL, objv[2], sl@0: TCL_LEAVE_ERR_MSG); sl@0: if (varValueObj == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetObjResult(interp, varValueObj); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?"); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetVar -- sl@0: * sl@0: * Change the value of a variable. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the malloc'ed string which is the character sl@0: * representation of the variable's new value. The caller must not sl@0: * modify this string. If the write operation was disallowed then NULL sl@0: * is returned; if the TCL_LEAVE_ERR_MSG flag is set, then an sl@0: * explanatory message will be left in the interp's result. Note that the sl@0: * returned string may not be the same as newValue; this is because sl@0: * variable traces may modify the variable's value. sl@0: * sl@0: * Side effects: sl@0: * If varName is defined as a local or global variable in interp, sl@0: * its value is changed to newValue. If varName isn't currently sl@0: * defined, then a new global variable by that name is created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_SetVar(interp, varName, newValue, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: CONST char *varName; /* Name of a variable in interp. */ sl@0: CONST char *newValue; /* New value for varName. */ sl@0: int flags; /* Various flags that tell how to set value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetVar2 -- sl@0: * sl@0: * Given a two-part variable name, which may refer either to a sl@0: * scalar variable or an element of an array, change the value sl@0: * of the variable. If the named scalar or array or element sl@0: * doesn't exist then create one. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the malloc'ed string which is the character sl@0: * representation of the variable's new value. The caller must not sl@0: * modify this string. If the write operation was disallowed because an sl@0: * array was expected but not found (or vice versa), then NULL is sl@0: * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory sl@0: * message will be left in the interp's result. Note that the returned sl@0: * string may not be the same as newValue; this is because variable sl@0: * traces may modify the variable's value. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is set. If either the array sl@0: * or the entry didn't exist then a new one is created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_SetVar2(interp, part1, part2, newValue, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: CONST char *part1; /* If part2 is NULL, this is name of scalar sl@0: * variable. Otherwise it is the name of sl@0: * an array. */ sl@0: CONST char *part2; /* Name of an element within an array, or sl@0: * NULL. */ sl@0: CONST char *newValue; /* New value for variable. */ sl@0: int flags; /* Various flags that tell how to set value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG */ sl@0: { sl@0: register Tcl_Obj *valuePtr; sl@0: Tcl_Obj *varValuePtr; sl@0: sl@0: /* sl@0: * Create an object holding the variable's new value and use sl@0: * Tcl_SetVar2Ex to actually set the variable. sl@0: */ sl@0: sl@0: valuePtr = Tcl_NewStringObj(newValue, -1); sl@0: Tcl_IncrRefCount(valuePtr); sl@0: sl@0: varValuePtr = Tcl_SetVar2Ex(interp, part1, part2, valuePtr, flags); sl@0: Tcl_DecrRefCount(valuePtr); /* done with the object */ sl@0: sl@0: if (varValuePtr == NULL) { sl@0: return NULL; sl@0: } sl@0: return TclGetString(varValuePtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetVar2Ex -- sl@0: * sl@0: * Given a two-part variable name, which may refer either to a scalar sl@0: * variable or an element of an array, change the value of the variable sl@0: * to a new Tcl object value. If the named scalar or array or element sl@0: * doesn't exist then create one. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the Tcl_Obj holding the new value of the sl@0: * variable. If the write operation was disallowed because an array was sl@0: * expected but not found (or vice versa), then NULL is returned; if sl@0: * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will sl@0: * be left in the interpreter's result. Note that the returned object sl@0: * may not be the same one referenced by newValuePtr; this is because sl@0: * variable traces may modify the variable's value. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is set. If either the array or the sl@0: * entry didn't exist then a new variable is created. sl@0: * sl@0: * The reference count is decremented for any old value of the variable sl@0: * and incremented for its new value. If the new value for the variable sl@0: * is not the same one referenced by newValuePtr (perhaps as a result sl@0: * of a variable trace), then newValuePtr's ref count is left unchanged sl@0: * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if sl@0: * we are appending it as a string value: that is, if "flags" includes sl@0: * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. sl@0: * sl@0: * The reference count for the returned object is _not_ incremented: if sl@0: * you want to keep a reference to the object you must increment its sl@0: * ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be found. */ sl@0: CONST char *part1; /* Name of an array (if part2 is non-NULL) sl@0: * or the name of a variable. */ sl@0: CONST char *part2; /* If non-NULL, gives the name of an element sl@0: * in the array part1. */ sl@0: Tcl_Obj *newValuePtr; /* New value for variable. */ sl@0: int flags; /* Various flags that tell how to set value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: sl@0: /* Filter to pass through only the flags this interface supports. */ sl@0: flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG sl@0: |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); sl@0: varPtr = TclLookupVar(interp, part1, part2, flags, "set", sl@0: /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, sl@0: newValuePtr, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ObjSetVar2 -- sl@0: * sl@0: * This function is the same as Tcl_SetVar2Ex above, except the sl@0: * variable names are passed in Tcl object instead of strings. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the Tcl_Obj holding the new value of the sl@0: * variable. If the write operation was disallowed because an array was sl@0: * expected but not found (or vice versa), then NULL is returned; if sl@0: * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will sl@0: * be left in the interpreter's result. Note that the returned object sl@0: * may not be the same one referenced by newValuePtr; this is because sl@0: * variable traces may modify the variable's value. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is set. If either the array or the sl@0: * entry didn't exist then a new variable is created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be found. */ sl@0: register Tcl_Obj *part1Ptr; /* Points to an object holding the name of sl@0: * an array (if part2 is non-NULL) or the sl@0: * name of a variable. */ sl@0: register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding sl@0: * the name of an element in the array sl@0: * part1Ptr. */ sl@0: Tcl_Obj *newValuePtr; /* New value for variable. */ sl@0: int flags; /* Various flags that tell how to set value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: char *part1, *part2; sl@0: sl@0: part1 = TclGetString(part1Ptr); sl@0: part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); sl@0: sl@0: /* Filter to pass through only the flags this interface supports. */ sl@0: flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG sl@0: |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); sl@0: varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", sl@0: /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, sl@0: newValuePtr, flags); sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclPtrSetVar -- sl@0: * sl@0: * This function is the same as Tcl_SetVar2Ex above, except that sl@0: * it requires pointers to the variable's Var structs in addition sl@0: * to the variable names. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the Tcl_Obj holding the new value of the sl@0: * variable. If the write operation was disallowed because an array was sl@0: * expected but not found (or vice versa), then NULL is returned; if sl@0: * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will sl@0: * be left in the interpreter's result. Note that the returned object sl@0: * may not be the same one referenced by newValuePtr; this is because sl@0: * variable traces may modify the variable's value. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is set. If either the array or the sl@0: * entry didn't exist then a new variable is created. sl@0: sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be looked up. */ sl@0: register Var *varPtr; sl@0: Var *arrayPtr; sl@0: CONST char *part1; /* Name of an array (if part2 is non-NULL) sl@0: * or the name of a variable. */ sl@0: CONST char *part2; /* If non-NULL, gives the name of an element sl@0: * in the array part1. */ sl@0: Tcl_Obj *newValuePtr; /* New value for variable. */ sl@0: CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * and TCL_LEAVE_ERR_MSG bits. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj *oldValuePtr; sl@0: Tcl_Obj *resultPtr = NULL; sl@0: int result; sl@0: sl@0: /* sl@0: * If the variable is in a hashtable and its hPtr field is NULL, then we sl@0: * may have an upvar to an array element where the array was deleted sl@0: * or an upvar to a namespace variable whose namespace was deleted. sl@0: * Generate an error (allowing the variable to be reset would screw up sl@0: * our storage allocation and is meaningless anyway). sl@0: */ sl@0: sl@0: if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: if (TclIsVarArrayElement(varPtr)) { sl@0: VarErrMsg(interp, part1, part2, "set", danglingElement); sl@0: } else { sl@0: VarErrMsg(interp, part1, part2, "set", danglingVar); sl@0: } sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * It's an error to try to set an array variable itself. sl@0: */ sl@0: sl@0: if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, part1, part2, "set", isArray); sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Invoke any read traces that have been set for the variable if it sl@0: * is requested; this is only done in the core by the INST_LAPPEND_* sl@0: * instructions. sl@0: */ sl@0: sl@0: if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) sl@0: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { sl@0: if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, sl@0: TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { sl@0: return NULL; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the variable's new value. If appending, append the new value to sl@0: * the variable, either as a list element or as a string. Also, if sl@0: * appending, then if the variable's old value is unshared we can modify sl@0: * it directly, otherwise we must create a new copy to modify: this is sl@0: * "copy on write". sl@0: */ sl@0: sl@0: if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { sl@0: TclSetVarUndefined(varPtr); sl@0: } sl@0: oldValuePtr = varPtr->value.objPtr; sl@0: if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { sl@0: if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { sl@0: Tcl_DecrRefCount(oldValuePtr); /* discard old value */ sl@0: varPtr->value.objPtr = NULL; sl@0: oldValuePtr = NULL; sl@0: } sl@0: if (flags & TCL_LIST_ELEMENT) { /* append list element */ sl@0: if (oldValuePtr == NULL) { sl@0: TclNewObj(oldValuePtr); sl@0: varPtr->value.objPtr = oldValuePtr; sl@0: Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ sl@0: } else if (Tcl_IsShared(oldValuePtr)) { sl@0: varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); sl@0: Tcl_DecrRefCount(oldValuePtr); sl@0: oldValuePtr = varPtr->value.objPtr; sl@0: Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ sl@0: } sl@0: result = Tcl_ListObjAppendElement(interp, oldValuePtr, sl@0: newValuePtr); sl@0: if (result != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: } else { /* append string */ sl@0: /* sl@0: * We append newValuePtr's bytes but don't change its ref count. sl@0: */ sl@0: sl@0: if (oldValuePtr == NULL) { sl@0: varPtr->value.objPtr = newValuePtr; sl@0: Tcl_IncrRefCount(newValuePtr); sl@0: } else { sl@0: if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ sl@0: varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); sl@0: TclDecrRefCount(oldValuePtr); sl@0: oldValuePtr = varPtr->value.objPtr; sl@0: Tcl_IncrRefCount(oldValuePtr); /* since var is ref */ sl@0: } sl@0: Tcl_AppendObjToObj(oldValuePtr, newValuePtr); sl@0: } sl@0: } sl@0: } else if (newValuePtr != oldValuePtr) { sl@0: /* sl@0: * In this case we are replacing the value, so we don't need to sl@0: * do more than swap the objects. sl@0: */ sl@0: sl@0: varPtr->value.objPtr = newValuePtr; sl@0: Tcl_IncrRefCount(newValuePtr); /* var is another ref */ sl@0: if (oldValuePtr != NULL) { sl@0: TclDecrRefCount(oldValuePtr); /* discard old value */ sl@0: } sl@0: } sl@0: TclSetVarScalar(varPtr); sl@0: TclClearVarUndefined(varPtr); sl@0: if (arrayPtr != NULL) { sl@0: TclClearVarUndefined(arrayPtr); sl@0: } sl@0: sl@0: /* sl@0: * Invoke any write traces for the variable. sl@0: */ sl@0: sl@0: if ((varPtr->tracePtr != NULL) sl@0: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { sl@0: if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, sl@0: (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) sl@0: | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { sl@0: goto cleanup; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Return the variable's value unless the variable was changed in some sl@0: * gross way by a trace (e.g. it was unset and then recreated as an sl@0: * array). sl@0: */ sl@0: sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { sl@0: return varPtr->value.objPtr; sl@0: } sl@0: sl@0: /* sl@0: * A trace changed the value in some gross way. Return an empty string sl@0: * object. sl@0: */ sl@0: sl@0: resultPtr = iPtr->emptyObjPtr; sl@0: sl@0: /* sl@0: * If the variable doesn't exist anymore and no-one's using it, then sl@0: * free up the relevant structures and hash table entries. sl@0: */ sl@0: sl@0: cleanup: sl@0: if (TclIsVarUndefined(varPtr)) { sl@0: CleanupVar(varPtr, arrayPtr); sl@0: } sl@0: return resultPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclIncrVar2 -- sl@0: * sl@0: * Given a two-part variable name, which may refer either to a scalar sl@0: * variable or an element of an array, increment the Tcl object value sl@0: * of the variable by a specified amount. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the Tcl_Obj holding the new value of the sl@0: * variable. If the specified variable doesn't exist, or there is a sl@0: * clash in array usage, or an error occurs while executing variable sl@0: * traces, then NULL is returned and a message will be left in sl@0: * the interpreter's result. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is incremented by the specified sl@0: * amount. If either the array or the entry didn't exist then a new sl@0: * variable is created. The ref count for the returned object is _not_ sl@0: * incremented to reflect the returned reference; if you want to keep a sl@0: * reference to the object you must increment its ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be found. */ sl@0: Tcl_Obj *part1Ptr; /* Points to an object holding the name of sl@0: * an array (if part2 is non-NULL) or the sl@0: * name of a variable. */ sl@0: Tcl_Obj *part2Ptr; /* If non-null, points to an object holding sl@0: * the name of an element in the array sl@0: * part1Ptr. */ sl@0: long incrAmount; /* Amount to be added to variable. */ sl@0: int flags; /* Various flags that tell how to incr value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: char *part1, *part2; sl@0: sl@0: part1 = TclGetString(part1Ptr); sl@0: part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); sl@0: sl@0: varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", sl@0: 0, 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: Tcl_AddObjErrorInfo(interp, sl@0: "\n (reading value of variable to increment)", -1); sl@0: return NULL; sl@0: } sl@0: return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, sl@0: incrAmount, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclPtrIncrVar -- sl@0: * sl@0: * Given the pointers to a variable and possible containing array, sl@0: * increment the Tcl object value of the variable by a specified sl@0: * amount. sl@0: * sl@0: * Results: sl@0: * Returns a pointer to the Tcl_Obj holding the new value of the sl@0: * variable. If the specified variable doesn't exist, or there is a sl@0: * clash in array usage, or an error occurs while executing variable sl@0: * traces, then NULL is returned and a message will be left in sl@0: * the interpreter's result. sl@0: * sl@0: * Side effects: sl@0: * The value of the given variable is incremented by the specified sl@0: * amount. If either the array or the entry didn't exist then a new sl@0: * variable is created. The ref count for the returned object is _not_ sl@0: * incremented to reflect the returned reference; if you want to keep a sl@0: * reference to the object you must increment its ref count yourself. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Tcl_Obj * sl@0: TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which variable is sl@0: * to be found. */ sl@0: Var *varPtr; sl@0: Var *arrayPtr; sl@0: CONST char *part1; /* Points to an object holding the name of sl@0: * an array (if part2 is non-NULL) or the sl@0: * name of a variable. */ sl@0: CONST char *part2; /* If non-null, points to an object holding sl@0: * the name of an element in the array sl@0: * part1Ptr. */ sl@0: CONST long incrAmount; /* Amount to be added to variable. */ sl@0: CONST int flags; /* Various flags that tell how to incr value: sl@0: * any of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, sl@0: * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: register Tcl_Obj *varValuePtr; sl@0: int createdNewObj; /* Set 1 if var's value object is shared sl@0: * so we must increment a copy (i.e. copy sl@0: * on write). */ sl@0: long i; sl@0: sl@0: varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); sl@0: sl@0: if (varValuePtr == NULL) { sl@0: Tcl_AddObjErrorInfo(interp, sl@0: "\n (reading value of variable to increment)", -1); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Increment the variable's value. If the object is unshared we can sl@0: * modify it directly, otherwise we must create a new copy to modify: sl@0: * this is "copy on write". Then free the variable's old string sl@0: * representation, if any, since it will no longer be valid. sl@0: */ sl@0: sl@0: createdNewObj = 0; sl@0: if (Tcl_IsShared(varValuePtr)) { sl@0: varValuePtr = Tcl_DuplicateObj(varValuePtr); sl@0: createdNewObj = 1; sl@0: } sl@0: if (varValuePtr->typePtr == &tclWideIntType) { sl@0: Tcl_WideInt wide; sl@0: TclGetWide(wide,varValuePtr); sl@0: Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); sl@0: } else if (varValuePtr->typePtr == &tclIntType) { sl@0: i = varValuePtr->internalRep.longValue; sl@0: Tcl_SetIntObj(varValuePtr, i + incrAmount); sl@0: } else { sl@0: /* sl@0: * Not an integer or wide internal-rep... sl@0: */ sl@0: Tcl_WideInt wide; sl@0: if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { sl@0: if (createdNewObj) { sl@0: Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ sl@0: } sl@0: return NULL; sl@0: } sl@0: if (wide <= Tcl_LongAsWide(LONG_MAX) sl@0: && wide >= Tcl_LongAsWide(LONG_MIN)) { sl@0: Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); sl@0: } else { sl@0: Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Store the variable's new value and run any write traces. sl@0: */ sl@0: sl@0: return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, sl@0: varValuePtr, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UnsetVar -- sl@0: * sl@0: * Delete a variable, so that it may not be accessed anymore. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR sl@0: * if the variable can't be unset. In the event of an error, sl@0: * if the TCL_LEAVE_ERR_MSG flag is set then an error message sl@0: * is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * If varName is defined as a local or global variable in interp, sl@0: * it is deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_UnsetVar(interp, varName, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: CONST char *varName; /* Name of a variable in interp. May be sl@0: * either a scalar name or an array name sl@0: * or an element in an array. */ sl@0: int flags; /* OR-ed combination of any of sl@0: * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or sl@0: * TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UnsetVar2 -- sl@0: * sl@0: * Delete a variable, given a 2-part name. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR sl@0: * if the variable can't be unset. In the event of an error, sl@0: * if the TCL_LEAVE_ERR_MSG flag is set then an error message sl@0: * is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * If part1 and part2 indicate a local or global variable in interp, sl@0: * it is deleted. If part1 is an array name and part2 is NULL, then sl@0: * the whole array is deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_UnsetVar2(interp, part1, part2, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: CONST char *part1; /* Name of variable or array. */ sl@0: CONST char *part2; /* Name of element within array or NULL. */ sl@0: int flags; /* OR-ed combination of any of sl@0: * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: int result; sl@0: Tcl_Obj *part1Ptr; sl@0: sl@0: part1Ptr = Tcl_NewStringObj(part1, -1); sl@0: Tcl_IncrRefCount(part1Ptr); sl@0: /* Filter to pass through only the flags this interface supports. */ sl@0: flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); sl@0: result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); sl@0: TclDecrRefCount(part1Ptr); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclObjUnsetVar2 -- sl@0: * sl@0: * Delete a variable, given a 2-object name. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR sl@0: * if the variable can't be unset. In the event of an error, sl@0: * if the TCL_LEAVE_ERR_MSG flag is set then an error message sl@0: * is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * If part1ptr and part2Ptr indicate a local or global variable in interp, sl@0: * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then sl@0: * the whole array is deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclObjUnsetVar2(interp, part1Ptr, part2, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: Tcl_Obj *part1Ptr; /* Name of variable or array. */ sl@0: CONST char *part2; /* Name of element within array or NULL. */ sl@0: int flags; /* OR-ed combination of any of sl@0: * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, sl@0: * TCL_LEAVE_ERR_MSG. */ sl@0: { sl@0: Var *varPtr; sl@0: Interp *iPtr = (Interp *) interp; sl@0: Var *arrayPtr; sl@0: int result; sl@0: char *part1; sl@0: sl@0: part1 = TclGetString(part1Ptr); sl@0: varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", sl@0: /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); sl@0: sl@0: /* sl@0: * Keep the variable alive until we're done with it. We used to sl@0: * increase/decrease the refCount for each operation, making it sl@0: * hard to find [Bug 735335] - caused by unsetting the variable sl@0: * whose value was the variable's name. sl@0: */ sl@0: sl@0: varPtr->refCount++; sl@0: sl@0: UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags); sl@0: sl@0: /* sl@0: * It's an error to unset an undefined variable. sl@0: */ sl@0: sl@0: if (result != TCL_OK) { sl@0: if (flags & TCL_LEAVE_ERR_MSG) { sl@0: VarErrMsg(interp, part1, part2, "unset", sl@0: ((arrayPtr == NULL) ? noSuchVar : noSuchElement)); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Try to avoid keeping the Var struct allocated due to a tclNsVarNameType sl@0: * keeping a reference. This removes some additional exteriorisations of sl@0: * [Bug 736729], but may be a good thing independently of the bug. sl@0: */ sl@0: sl@0: if (part1Ptr->typePtr == &tclNsVarNameType) { sl@0: part1Ptr->typePtr->freeIntRepProc(part1Ptr); sl@0: part1Ptr->typePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * Finally, if the variable is truly not in use then free up its Var sl@0: * structure and remove it from its hash table, if any. The ref count of sl@0: * its value object, if any, was decremented above. sl@0: */ sl@0: sl@0: varPtr->refCount--; sl@0: CleanupVar(varPtr, arrayPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UnsetVarStruct -- sl@0: * sl@0: * Unset and delete a variable. This does the internal work for sl@0: * TclObjUnsetVar2 and TclDeleteNamespaceVars, which call here for each sl@0: * variable to be unset and deleted. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If the arguments indicate a local or global variable in iPtr, it is sl@0: * unset and deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags) sl@0: Var *varPtr; sl@0: Var *arrayPtr; sl@0: Interp *iPtr; sl@0: CONST char *part1; sl@0: CONST char *part2; sl@0: int flags; sl@0: { sl@0: Var dummyVar; sl@0: Var *dummyVarPtr; sl@0: ActiveVarTrace *activePtr; sl@0: sl@0: if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { sl@0: DeleteSearches(arrayPtr); sl@0: } sl@0: sl@0: /* sl@0: * For global/upvar variables referenced in procedures, decrement sl@0: * the reference count on the variable referred to, and free sl@0: * the referenced variable if it's no longer needed. sl@0: */ sl@0: sl@0: if (TclIsVarLink(varPtr)) { sl@0: Var *linkPtr = varPtr->value.linkPtr; sl@0: linkPtr->refCount--; sl@0: if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) sl@0: && (linkPtr->tracePtr == NULL) sl@0: && (linkPtr->flags & VAR_IN_HASHTABLE)) { sl@0: if (linkPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(linkPtr->hPtr); sl@0: } sl@0: ckfree((char *) linkPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * The code below is tricky, because of the possibility that sl@0: * a trace procedure might try to access a variable being sl@0: * deleted. To handle this situation gracefully, do things sl@0: * in three steps: sl@0: * 1. Copy the contents of the variable to a dummy variable sl@0: * structure, and mark the original Var structure as undefined. sl@0: * 2. Invoke traces and clean up the variable, using the dummy copy. sl@0: * 3. If at the end of this the original variable is still sl@0: * undefined and has no outstanding references, then delete sl@0: * it (but it could have gotten recreated by a trace). sl@0: */ sl@0: sl@0: dummyVar = *varPtr; sl@0: TclSetVarUndefined(varPtr); sl@0: TclSetVarScalar(varPtr); sl@0: varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ sl@0: varPtr->tracePtr = NULL; sl@0: varPtr->searchPtr = NULL; sl@0: sl@0: /* sl@0: * Call trace procedures for the variable being deleted. Then delete sl@0: * its traces. Be sure to abort any other traces for the variable sl@0: * that are still pending. Special tricks: sl@0: * 1. We need to increment varPtr's refCount around this: CallVarTraces sl@0: * will use dummyVar so it won't increment varPtr's refCount itself. sl@0: * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to sl@0: * call unset traces even if other traces are pending. sl@0: */ sl@0: sl@0: if ((dummyVar.tracePtr != NULL) sl@0: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { sl@0: dummyVar.flags &= ~VAR_TRACE_ACTIVE; sl@0: CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, sl@0: (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) sl@0: | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); sl@0: while (dummyVar.tracePtr != NULL) { sl@0: VarTrace *tracePtr = dummyVar.tracePtr; sl@0: dummyVar.tracePtr = tracePtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); sl@0: } sl@0: for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->varPtr == varPtr) { sl@0: activePtr->nextTracePtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If the variable is an array, delete all of its elements. This must be sl@0: * done after calling the traces on the array, above (that's the way sl@0: * traces are defined). If it is a scalar, "discard" its object sl@0: * (decrement the ref count of its object, if any). sl@0: */ sl@0: sl@0: dummyVarPtr = &dummyVar; sl@0: if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { sl@0: DeleteArray(iPtr, part1, dummyVarPtr, (flags sl@0: & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); sl@0: } sl@0: if (TclIsVarScalar(dummyVarPtr) sl@0: && (dummyVarPtr->value.objPtr != NULL)) { sl@0: Tcl_Obj *objPtr = dummyVarPtr->value.objPtr; sl@0: TclDecrRefCount(objPtr); sl@0: dummyVarPtr->value.objPtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * If the variable was a namespace variable, decrement its reference count. sl@0: */ sl@0: sl@0: if (varPtr->flags & VAR_NAMESPACE_VAR) { sl@0: varPtr->flags &= ~VAR_NAMESPACE_VAR; sl@0: varPtr->refCount--; sl@0: } sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_TraceVar -- sl@0: * sl@0: * Arrange for reads and/or writes to a variable to cause a sl@0: * procedure to be invoked, which can monitor the operations sl@0: * and/or change their actions. sl@0: * sl@0: * Results: sl@0: * A standard Tcl return value. sl@0: * sl@0: * Side effects: sl@0: * A trace is set up on the variable given by varName, such that sl@0: * future references to the variable will be intermediated by sl@0: * proc. See the manual entry for complete details on the calling sl@0: * sequence for proc. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_TraceVar(interp, varName, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which variable is sl@0: * to be traced. */ sl@0: CONST char *varName; /* Name of variable; may end with "(index)" sl@0: * to signify an array reference. */ sl@0: int flags; /* OR-ed collection of bits, including any sl@0: * of TCL_TRACE_READS, TCL_TRACE_WRITES, sl@0: * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and sl@0: * TCL_NAMESPACE_ONLY. */ sl@0: Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are sl@0: * invoked upon varName. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: return Tcl_TraceVar2(interp, varName, (char *) NULL, sl@0: flags, proc, clientData); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_TraceVar2 -- sl@0: * sl@0: * Arrange for reads and/or writes to a variable to cause a sl@0: * procedure to be invoked, which can monitor the operations sl@0: * and/or change their actions. sl@0: * sl@0: * Results: sl@0: * A standard Tcl return value. sl@0: * sl@0: * Side effects: sl@0: * A trace is set up on the variable given by part1 and part2, such sl@0: * that future references to the variable will be intermediated by sl@0: * proc. See the manual entry for complete details on the calling sl@0: * sequence for proc. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter in which variable is sl@0: * to be traced. */ sl@0: CONST char *part1; /* Name of scalar variable or array. */ sl@0: CONST char *part2; /* Name of element within array; NULL means sl@0: * trace applies to scalar variable or array sl@0: * as-a-whole. */ sl@0: int flags; /* OR-ed collection of bits, including any sl@0: * of TCL_TRACE_READS, TCL_TRACE_WRITES, sl@0: * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, sl@0: * and TCL_NAMESPACE_ONLY. */ sl@0: Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are sl@0: * invoked upon varName. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: register VarTrace *tracePtr; sl@0: int flagMask; sl@0: sl@0: /* sl@0: * We strip 'flags' down to just the parts which are relevant to sl@0: * TclLookupVar, to avoid conflicts between trace flags and sl@0: * internal namespace flags such as 'FIND_ONLY_NS'. This can sl@0: * now occur since we have trace flags with values 0x1000 and higher. sl@0: */ sl@0: flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; sl@0: varPtr = TclLookupVar(interp, part1, part2, sl@0: (flags & flagMask) | TCL_LEAVE_ERR_MSG, sl@0: "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Check for a nonsense flag combination. Note that this is a sl@0: * panic() because there should be no code path that ever sets sl@0: * both flags. sl@0: */ sl@0: if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { sl@0: panic("bad result flag combination"); sl@0: } sl@0: sl@0: /* sl@0: * Set up trace information. sl@0: */ sl@0: sl@0: flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | sl@0: TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: flagMask |= TCL_TRACE_OLD_STYLE; sl@0: #endif sl@0: tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); sl@0: tracePtr->traceProc = proc; sl@0: tracePtr->clientData = clientData; sl@0: tracePtr->flags = flags & flagMask; sl@0: tracePtr->nextPtr = varPtr->tracePtr; sl@0: varPtr->tracePtr = tracePtr; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UntraceVar -- sl@0: * sl@0: * Remove a previously-created trace for a variable. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If there exists a trace for the variable given by varName sl@0: * with the given flags, proc, and clientData, then that trace sl@0: * is removed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_UntraceVar(interp, varName, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *varName; /* Name of variable; may end with "(index)" sl@0: * to signify an array reference. */ sl@0: int flags; /* OR-ed collection of bits describing sl@0: * current trace, including any of sl@0: * TCL_TRACE_READS, TCL_TRACE_WRITES, sl@0: * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY sl@0: * and TCL_NAMESPACE_ONLY. */ sl@0: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UntraceVar2 -- sl@0: * sl@0: * Remove a previously-created trace for a variable. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If there exists a trace for the variable given by part1 sl@0: * and part2 with the given flags, proc, and clientData, then sl@0: * that trace is removed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *part1; /* Name of variable or array. */ sl@0: CONST char *part2; /* Name of element within array; NULL means sl@0: * trace applies to scalar variable or array sl@0: * as-a-whole. */ sl@0: int flags; /* OR-ed collection of bits describing sl@0: * current trace, including any of sl@0: * TCL_TRACE_READS, TCL_TRACE_WRITES, sl@0: * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, sl@0: * and TCL_NAMESPACE_ONLY. */ sl@0: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData clientData; /* Arbitrary argument to pass to proc. */ sl@0: { sl@0: register VarTrace *tracePtr; sl@0: VarTrace *prevPtr; sl@0: Var *varPtr, *arrayPtr; sl@0: Interp *iPtr = (Interp *) interp; sl@0: ActiveVarTrace *activePtr; sl@0: int flagMask; sl@0: sl@0: /* sl@0: * Set up a mask to mask out the parts of the flags that we are not sl@0: * interested in now. sl@0: */ sl@0: flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; sl@0: varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, sl@0: /*msg*/ (char *) NULL, sl@0: /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return; sl@0: } sl@0: sl@0: sl@0: /* sl@0: * Set up a mask to mask out the parts of the flags that we are not sl@0: * interested in now. sl@0: */ sl@0: flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | sl@0: TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; sl@0: #ifndef TCL_REMOVE_OBSOLETE_TRACES sl@0: flagMask |= TCL_TRACE_OLD_STYLE; sl@0: #endif sl@0: flags &= flagMask; sl@0: for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; sl@0: prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { sl@0: if (tracePtr == NULL) { sl@0: return; sl@0: } sl@0: if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags) sl@0: && (tracePtr->clientData == clientData)) { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * The code below makes it possible to delete traces while traces sl@0: * are active: it makes sure that the deleted trace won't be sl@0: * processed by CallVarTraces. sl@0: */ sl@0: sl@0: for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->nextTracePtr == tracePtr) { sl@0: activePtr->nextTracePtr = tracePtr->nextPtr; sl@0: } sl@0: } sl@0: if (prevPtr == NULL) { sl@0: varPtr->tracePtr = tracePtr->nextPtr; sl@0: } else { sl@0: prevPtr->nextPtr = tracePtr->nextPtr; sl@0: } sl@0: Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); sl@0: sl@0: /* sl@0: * If this is the last trace on the variable, and the variable is sl@0: * unset and unused, then free up the variable. sl@0: */ sl@0: sl@0: if (TclIsVarUndefined(varPtr)) { sl@0: CleanupVar(varPtr, (Var *) NULL); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_VarTraceInfo -- sl@0: * sl@0: * Return the clientData value associated with a trace on a sl@0: * variable. This procedure can also be used to step through sl@0: * all of the traces on a particular variable that have the sl@0: * same trace procedure. sl@0: * sl@0: * Results: sl@0: * The return value is the clientData value associated with sl@0: * a trace on the given variable. Information will only be sl@0: * returned for a trace with proc as trace procedure. If sl@0: * the clientData argument is NULL then the first such trace is sl@0: * returned; otherwise, the next relevant one after the one sl@0: * given by clientData will be returned. If the variable sl@0: * doesn't exist, or if there are no (more) traces for it, sl@0: * then NULL is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *varName; /* Name of variable; may end with "(index)" sl@0: * to signify an array reference. */ sl@0: int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY (can be 0). */ sl@0: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData prevClientData; /* If non-NULL, gives last value returned sl@0: * by this procedure, so this call will sl@0: * return the next trace after that one. sl@0: * If NULL, this call will return the sl@0: * first trace. */ sl@0: { sl@0: return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, sl@0: flags, proc, prevClientData); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_VarTraceInfo2 -- sl@0: * sl@0: * Same as Tcl_VarTraceInfo, except takes name in two pieces sl@0: * instead of one. sl@0: * sl@0: * Results: sl@0: * Same as Tcl_VarTraceInfo. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C ClientData sl@0: Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *part1; /* Name of variable or array. */ sl@0: CONST char *part2; /* Name of element within array; NULL means sl@0: * trace applies to scalar variable or array sl@0: * as-a-whole. */ sl@0: int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, sl@0: * TCL_NAMESPACE_ONLY. */ sl@0: Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */ sl@0: ClientData prevClientData; /* If non-NULL, gives last value returned sl@0: * by this procedure, so this call will sl@0: * return the next trace after that one. sl@0: * If NULL, this call will return the sl@0: * first trace. */ sl@0: { sl@0: register VarTrace *tracePtr; sl@0: Var *varPtr, *arrayPtr; sl@0: sl@0: varPtr = TclLookupVar(interp, part1, part2, sl@0: flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), sl@0: /*msg*/ (char *) NULL, sl@0: /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Find the relevant trace, if any, and return its clientData. sl@0: */ sl@0: sl@0: tracePtr = varPtr->tracePtr; sl@0: if (prevClientData != NULL) { sl@0: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { sl@0: if ((tracePtr->clientData == prevClientData) sl@0: && (tracePtr->traceProc == proc)) { sl@0: tracePtr = tracePtr->nextPtr; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { sl@0: if (tracePtr->traceProc == proc) { sl@0: return tracePtr->clientData; sl@0: } sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UnsetObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "unset" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_UnsetObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: register int i, flags = TCL_LEAVE_ERR_MSG; sl@0: register char *name; sl@0: sl@0: if (objc < 1) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?-nocomplain? ?--? ?varName varName ...?"); sl@0: return TCL_ERROR; sl@0: } else if (objc == 1) { sl@0: /* sl@0: * Do nothing if no arguments supplied, so as to match sl@0: * command documentation. sl@0: */ sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Simple, restrictive argument parsing. The only options are -- sl@0: * and -nocomplain (which must come first and be given exactly to sl@0: * be an option). sl@0: */ sl@0: i = 1; sl@0: name = TclGetString(objv[i]); sl@0: if (name[0] == '-') { sl@0: if (strcmp("-nocomplain", name) == 0) { sl@0: i++; sl@0: if (i == objc) { sl@0: return TCL_OK; sl@0: } sl@0: flags = 0; sl@0: name = TclGetString(objv[i]); sl@0: } sl@0: if (strcmp("--", name) == 0) { sl@0: i++; sl@0: } sl@0: } sl@0: sl@0: for (; i < objc; i++) { sl@0: if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK) sl@0: && (flags == TCL_LEAVE_ERR_MSG)) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_AppendObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "append" sl@0: * Tcl command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * A variable's value may be changed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_AppendObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: char *part1; sl@0: sl@0: register Tcl_Obj *varValuePtr = NULL; sl@0: /* Initialized to avoid compiler sl@0: * warning. */ sl@0: int i; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (objc == 2) { sl@0: varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); sl@0: if (varValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, sl@0: "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: part1 = TclGetString(objv[1]); sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: for (i = 2; i < objc; i++) { sl@0: /* sl@0: * Note that we do not need to increase the refCount of sl@0: * the Var pointers: should a trace delete the variable, sl@0: * the return value of TclPtrSetVar will be NULL, and we sl@0: * will not access the variable again. sl@0: */ sl@0: sl@0: varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, sl@0: objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); sl@0: if (varValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: Tcl_SetObjResult(interp, varValuePtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_LappendObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "lappend" sl@0: * Tcl command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * A variable's value may be changed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_LappendObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Tcl_Obj *varValuePtr, *newValuePtr; sl@0: register List *listRepPtr; sl@0: register Tcl_Obj **elemPtrs; sl@0: int numElems, numRequired, createdNewObj, i, j; sl@0: Var *varPtr, *arrayPtr; sl@0: char *part1; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (objc == 2) { sl@0: newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0); sl@0: if (newValuePtr == NULL) { sl@0: /* sl@0: * The variable doesn't exist yet. Just create it with an empty sl@0: * initial value. sl@0: */ sl@0: sl@0: varValuePtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(varValuePtr); sl@0: newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, sl@0: TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(varValuePtr); sl@0: if (newValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: int result; sl@0: sl@0: result = Tcl_ListObjLength(interp, newValuePtr, &numElems); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: } else { sl@0: /* sl@0: * We have arguments to append. We used to call Tcl_SetVar2 to sl@0: * append each argument one at a time to ensure that traces were run sl@0: * for each append step. We now append the arguments all at once sl@0: * because it's faster. Note that a read trace and a write trace for sl@0: * the variable will now each only be called once. Also, if the sl@0: * variable's old value is unshared we modify it directly, otherwise sl@0: * we create a new copy to modify: this is "copy on write". sl@0: * sl@0: * Note that you have to protect the variable pointers around sl@0: * the TclPtrGetVar call to insure that they remain valid sl@0: * even if the variable was undefined and unused. sl@0: */ sl@0: sl@0: varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, sl@0: "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: varPtr->refCount++; sl@0: if (arrayPtr != NULL) { sl@0: arrayPtr->refCount++; sl@0: } sl@0: part1 = TclGetString(objv[1]); sl@0: varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, sl@0: TCL_LEAVE_ERR_MSG); sl@0: varPtr->refCount--; sl@0: if (arrayPtr != NULL) { sl@0: arrayPtr->refCount--; sl@0: } sl@0: sl@0: createdNewObj = 0; sl@0: if (varValuePtr == NULL) { sl@0: /* sl@0: * We couldn't read the old value: either the var doesn't yet sl@0: * exist or it's an array element. If it's new, we will try to sl@0: * create it with Tcl_ObjSetVar2 below. sl@0: */ sl@0: sl@0: varValuePtr = Tcl_NewObj(); sl@0: createdNewObj = 1; sl@0: } else if (Tcl_IsShared(varValuePtr)) { sl@0: varValuePtr = Tcl_DuplicateObj(varValuePtr); sl@0: createdNewObj = 1; sl@0: } sl@0: sl@0: /* sl@0: * Convert the variable's old value to a list object if necessary. sl@0: */ sl@0: sl@0: if (varValuePtr->typePtr != &tclListType) { sl@0: int result = tclListType.setFromAnyProc(interp, varValuePtr); sl@0: if (result != TCL_OK) { sl@0: if (createdNewObj) { sl@0: Tcl_DecrRefCount(varValuePtr); /* free unneeded obj. */ sl@0: } sl@0: return result; sl@0: } sl@0: } sl@0: listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1; sl@0: elemPtrs = listRepPtr->elements; sl@0: numElems = listRepPtr->elemCount; sl@0: sl@0: /* sl@0: * If there is no room in the current array of element pointers, sl@0: * allocate a new, larger array and copy the pointers to it. sl@0: */ sl@0: sl@0: numRequired = numElems + (objc-2); sl@0: if (numRequired > listRepPtr->maxElemCount) { sl@0: int newMax = (2 * numRequired); sl@0: Tcl_Obj **newElemPtrs = (Tcl_Obj **) sl@0: ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *))); sl@0: sl@0: memcpy((VOID *) newElemPtrs, (VOID *) elemPtrs, sl@0: (size_t) (numElems * sizeof(Tcl_Obj *))); sl@0: listRepPtr->maxElemCount = newMax; sl@0: listRepPtr->elements = newElemPtrs; sl@0: ckfree((char *) elemPtrs); sl@0: elemPtrs = newElemPtrs; sl@0: } sl@0: sl@0: /* sl@0: * Insert the new elements at the end of the list. sl@0: */ sl@0: sl@0: for (i = 2, j = numElems; i < objc; i++, j++) { sl@0: elemPtrs[j] = objv[i]; sl@0: Tcl_IncrRefCount(objv[i]); sl@0: } sl@0: listRepPtr->elemCount = numRequired; sl@0: sl@0: /* sl@0: * Invalidate and free any old string representation since it no sl@0: * longer reflects the list's internal representation. sl@0: */ sl@0: sl@0: Tcl_InvalidateStringRep(varValuePtr); sl@0: sl@0: /* sl@0: * Now store the list object back into the variable. If there is an sl@0: * error setting the new value, decrement its ref count if it sl@0: * was new and we didn't create the variable. sl@0: */ sl@0: sl@0: Tcl_IncrRefCount(varValuePtr); sl@0: newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, sl@0: varValuePtr, TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(varValuePtr); sl@0: if (newValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to refer to the variable's value sl@0: * object. sl@0: */ sl@0: sl@0: Tcl_SetObjResult(interp, newValuePtr); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ArrayObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "array" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result object. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_ArrayObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: /* sl@0: * The list of constants below should match the arrayOptions string array sl@0: * below. sl@0: */ sl@0: sl@0: enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, sl@0: ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, sl@0: ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; sl@0: static CONST char *arrayOptions[] = { sl@0: "anymore", "donesearch", "exists", "get", "names", "nextelement", sl@0: "set", "size", "startsearch", "statistics", "unset", (char *) NULL sl@0: }; sl@0: sl@0: Interp *iPtr = (Interp *) interp; sl@0: Var *varPtr, *arrayPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: Tcl_Obj *resultPtr, *varNamePtr; sl@0: int notArray; sl@0: char *varName; sl@0: int index, result; sl@0: sl@0: sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", sl@0: 0, &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Locate the array variable sl@0: */ sl@0: sl@0: varNamePtr = objv[2]; sl@0: varName = TclGetString(varNamePtr); sl@0: varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0, sl@0: /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); sl@0: sl@0: /* sl@0: * Special array trace used to keep the env array in sync for sl@0: * array names, array get, etc. sl@0: */ sl@0: sl@0: if (varPtr != NULL && varPtr->tracePtr != NULL sl@0: && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { sl@0: if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL, sl@0: (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| sl@0: TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Verify that it is indeed an array variable. This test comes after sl@0: * the traces - the variable may actually become an array as an effect sl@0: * of said traces. sl@0: */ sl@0: sl@0: notArray = 0; sl@0: if ((varPtr == NULL) || !TclIsVarArray(varPtr) sl@0: || TclIsVarUndefined(varPtr)) { sl@0: notArray = 1; sl@0: } sl@0: sl@0: /* sl@0: * We have to wait to get the resultPtr until here because sl@0: * CallVarTraces can affect the result. sl@0: */ sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: switch (index) { sl@0: case ARRAY_ANYMORE: { sl@0: ArraySearch *searchPtr; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "arrayName searchId"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: goto error; sl@0: } sl@0: searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); sl@0: if (searchPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: while (1) { sl@0: Var *varPtr2; sl@0: sl@0: if (searchPtr->nextEntry != NULL) { sl@0: varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); sl@0: if (!TclIsVarUndefined(varPtr2)) { sl@0: break; sl@0: } sl@0: } sl@0: searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); sl@0: if (searchPtr->nextEntry == NULL) { sl@0: Tcl_SetIntObj(resultPtr, 0); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: Tcl_SetIntObj(resultPtr, 1); sl@0: break; sl@0: } sl@0: case ARRAY_DONESEARCH: { sl@0: ArraySearch *searchPtr, *prevPtr; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "arrayName searchId"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: goto error; sl@0: } sl@0: searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); sl@0: if (searchPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (varPtr->searchPtr == searchPtr) { sl@0: varPtr->searchPtr = searchPtr->nextPtr; sl@0: } else { sl@0: for (prevPtr = varPtr->searchPtr; ; sl@0: prevPtr = prevPtr->nextPtr) { sl@0: if (prevPtr->nextPtr == searchPtr) { sl@0: prevPtr->nextPtr = searchPtr->nextPtr; sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: ckfree((char *) searchPtr); sl@0: break; sl@0: } sl@0: case ARRAY_EXISTS: { sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_SetIntObj(resultPtr, !notArray); sl@0: break; sl@0: } sl@0: case ARRAY_GET: { sl@0: Tcl_HashSearch search; sl@0: Var *varPtr2; sl@0: char *pattern = NULL; sl@0: char *name; sl@0: Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; sl@0: int i, count; sl@0: sl@0: if ((objc != 3) && (objc != 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: return TCL_OK; sl@0: } sl@0: if (objc == 4) { sl@0: pattern = TclGetString(objv[3]); sl@0: } sl@0: sl@0: /* sl@0: * Store the array names in a new object. sl@0: */ sl@0: sl@0: nameLstPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(nameLstPtr); sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr2 = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (TclIsVarUndefined(varPtr2)) { sl@0: continue; sl@0: } sl@0: name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); sl@0: if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { sl@0: continue; /* element name doesn't match pattern */ sl@0: } sl@0: sl@0: namePtr = Tcl_NewStringObj(name, -1); sl@0: result = Tcl_ListObjAppendElement(interp, nameLstPtr, sl@0: namePtr); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ sl@0: Tcl_DecrRefCount(nameLstPtr); sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Make sure the Var structure of the array is not removed by sl@0: * a trace while we're working. sl@0: */ sl@0: sl@0: varPtr->refCount++; sl@0: sl@0: /* sl@0: * Get the array values corresponding to each element name sl@0: */ sl@0: sl@0: tmpResPtr = Tcl_NewObj(); sl@0: result = Tcl_ListObjGetElements(interp, nameLstPtr, sl@0: &count, &namePtrPtr); sl@0: if (result != TCL_OK) { sl@0: goto errorInArrayGet; sl@0: } sl@0: sl@0: for (i = 0; i < count; i++) { sl@0: namePtr = *namePtrPtr++; sl@0: valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, sl@0: TCL_LEAVE_ERR_MSG); sl@0: if (valuePtr == NULL) { sl@0: /* sl@0: * Some trace played a trick on us; we need to diagnose to sl@0: * adapt our behaviour: was the array element unset, or did sl@0: * the modification modify the complete array? sl@0: */ sl@0: sl@0: if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { sl@0: /* sl@0: * The array itself looks OK, the variable was sl@0: * undefined: forget it. sl@0: */ sl@0: sl@0: continue; sl@0: } else { sl@0: result = TCL_ERROR; sl@0: goto errorInArrayGet; sl@0: } sl@0: } sl@0: result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr); sl@0: if (result != TCL_OK) { sl@0: goto errorInArrayGet; sl@0: } sl@0: result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr); sl@0: if (result != TCL_OK) { sl@0: goto errorInArrayGet; sl@0: } sl@0: } sl@0: varPtr->refCount--; sl@0: Tcl_SetObjResult(interp, tmpResPtr); sl@0: Tcl_DecrRefCount(nameLstPtr); sl@0: break; sl@0: sl@0: errorInArrayGet: sl@0: varPtr->refCount--; sl@0: Tcl_DecrRefCount(nameLstPtr); sl@0: Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */ sl@0: return result; sl@0: } sl@0: case ARRAY_NAMES: { sl@0: Tcl_HashSearch search; sl@0: Var *varPtr2; sl@0: char *pattern = NULL; sl@0: char *name; sl@0: Tcl_Obj *namePtr; sl@0: int mode, matched = 0; sl@0: static CONST char *options[] = { sl@0: "-exact", "-glob", "-regexp", (char *) NULL sl@0: }; sl@0: enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; sl@0: sl@0: mode = OPT_GLOB; sl@0: sl@0: if ((objc < 3) || (objc > 5)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "arrayName ?mode? ?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: return TCL_OK; sl@0: } sl@0: if (objc == 4) { sl@0: pattern = Tcl_GetString(objv[3]); sl@0: } else if (objc == 5) { sl@0: pattern = Tcl_GetString(objv[4]); sl@0: if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", sl@0: 0, &mode) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr2 = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (TclIsVarUndefined(varPtr2)) { sl@0: continue; sl@0: } sl@0: name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); sl@0: if (objc > 3) { sl@0: switch ((enum options) mode) { sl@0: case OPT_EXACT: sl@0: matched = (strcmp(name, pattern) == 0); sl@0: break; sl@0: case OPT_GLOB: sl@0: matched = Tcl_StringMatch(name, pattern); sl@0: break; sl@0: case OPT_REGEXP: sl@0: matched = Tcl_RegExpMatch(interp, name, sl@0: pattern); sl@0: if (matched < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: if (matched == 0) { sl@0: continue; sl@0: } sl@0: } sl@0: sl@0: namePtr = Tcl_NewStringObj(name, -1); sl@0: result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); sl@0: if (result != TCL_OK) { sl@0: Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ sl@0: return result; sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case ARRAY_NEXTELEMENT: { sl@0: ArraySearch *searchPtr; sl@0: Tcl_HashEntry *hPtr; sl@0: sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "arrayName searchId"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: goto error; sl@0: } sl@0: searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); sl@0: if (searchPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: while (1) { sl@0: Var *varPtr2; sl@0: sl@0: hPtr = searchPtr->nextEntry; sl@0: if (hPtr == NULL) { sl@0: hPtr = Tcl_NextHashEntry(&searchPtr->search); sl@0: if (hPtr == NULL) { sl@0: return TCL_OK; sl@0: } sl@0: } else { sl@0: searchPtr->nextEntry = NULL; sl@0: } sl@0: varPtr2 = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (!TclIsVarUndefined(varPtr2)) { sl@0: break; sl@0: } sl@0: } sl@0: Tcl_SetStringObj(resultPtr, sl@0: Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1); sl@0: break; sl@0: } sl@0: case ARRAY_SET: { sl@0: if (objc != 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName list"); sl@0: return TCL_ERROR; sl@0: } sl@0: return(TclArraySet(interp, objv[2], objv[3])); sl@0: } sl@0: case ARRAY_SIZE: { sl@0: Tcl_HashSearch search; sl@0: Var *varPtr2; sl@0: int size; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); sl@0: return TCL_ERROR; sl@0: } sl@0: size = 0; sl@0: if (!notArray) { sl@0: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, sl@0: &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr2 = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (TclIsVarUndefined(varPtr2)) { sl@0: continue; sl@0: } sl@0: size++; sl@0: } sl@0: } sl@0: Tcl_SetIntObj(resultPtr, size); sl@0: break; sl@0: } sl@0: case ARRAY_STARTSEARCH: { sl@0: ArraySearch *searchPtr; sl@0: sl@0: if (objc != 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: goto error; sl@0: } sl@0: searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); sl@0: if (varPtr->searchPtr == NULL) { sl@0: searchPtr->id = 1; sl@0: Tcl_AppendStringsToObj(resultPtr, "s-1-", varName, sl@0: (char *) NULL); sl@0: } else { sl@0: char string[TCL_INTEGER_SPACE]; sl@0: sl@0: searchPtr->id = varPtr->searchPtr->id + 1; sl@0: TclFormatInt(string, searchPtr->id); sl@0: Tcl_AppendStringsToObj(resultPtr, "s-", string, "-", varName, sl@0: (char *) NULL); sl@0: } sl@0: searchPtr->varPtr = varPtr; sl@0: searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, sl@0: &searchPtr->search); sl@0: searchPtr->nextPtr = varPtr->searchPtr; sl@0: varPtr->searchPtr = searchPtr; sl@0: break; sl@0: } sl@0: sl@0: case ARRAY_STATISTICS: { sl@0: CONST char *stats; sl@0: sl@0: if (notArray) { sl@0: goto error; sl@0: } sl@0: sl@0: stats = Tcl_HashStats(varPtr->value.tablePtr); sl@0: if (stats != NULL) { sl@0: Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1); sl@0: ckfree((void *)stats); sl@0: } else { sl@0: Tcl_SetResult(interp, "error reading array statistics", sl@0: TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: sl@0: case ARRAY_UNSET: { sl@0: Tcl_HashSearch search; sl@0: Var *varPtr2; sl@0: char *pattern = NULL; sl@0: char *name; sl@0: sl@0: if ((objc != 3) && (objc != 4)) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); sl@0: return TCL_ERROR; sl@0: } sl@0: if (notArray) { sl@0: return TCL_OK; sl@0: } sl@0: if (objc == 3) { sl@0: /* sl@0: * When no pattern is given, just unset the whole array sl@0: */ sl@0: if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: pattern = Tcl_GetString(objv[3]); sl@0: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, sl@0: &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr2 = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (TclIsVarUndefined(varPtr2)) { sl@0: continue; sl@0: } sl@0: name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); sl@0: if (Tcl_StringMatch(name, pattern) && sl@0: (TclObjUnsetVar2(interp, varNamePtr, name, 0) sl@0: != TCL_OK)) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: sl@0: error: sl@0: Tcl_AppendStringsToObj(resultPtr, "\"", varName, "\" isn't an array", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclArraySet -- sl@0: * sl@0: * Set the elements of an array. If there are no elements to sl@0: * set, create an empty array. This routine is used by the sl@0: * Tcl_ArrayObjCmd and by the TclSetupEnv routine. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result object. sl@0: * sl@0: * Side effects: sl@0: * A variable will be created if one does not already exist. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclArraySet(interp, arrayNameObj, arrayElemObj) sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: Tcl_Obj *arrayNameObj; /* The array name. */ sl@0: Tcl_Obj *arrayElemObj; /* The array elements list. If this is sl@0: * NULL, create an empty array. */ sl@0: { sl@0: Var *varPtr, *arrayPtr; sl@0: Tcl_Obj **elemPtrs; sl@0: int result, elemLen, i, nameLen; sl@0: char *varName, *p; sl@0: sl@0: varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen); sl@0: p = varName + nameLen - 1; sl@0: if (*p == ')') { sl@0: while (--p >= varName) { sl@0: if (*p == '(') { sl@0: VarErrMsg(interp, varName, NULL, "set", needArray); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: sl@0: varPtr = TclObjLookupVar(interp, arrayNameObj, NULL, sl@0: /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, sl@0: /*createPart2*/ 0, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (arrayElemObj != NULL) { sl@0: result = Tcl_ListObjGetElements(interp, arrayElemObj, sl@0: &elemLen, &elemPtrs); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: if (elemLen & 1) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "list must have an even number of elements", -1); sl@0: return TCL_ERROR; sl@0: } sl@0: if (elemLen > 0) { sl@0: /* sl@0: * We needn't worry about traces invalidating arrayPtr: sl@0: * should that be the case, TclPtrSetVar will return NULL sl@0: * so that we break out of the loop and return an error. sl@0: */ sl@0: sl@0: for (i = 0; i < elemLen; i += 2) { sl@0: char *part2 = TclGetString(elemPtrs[i]); sl@0: Var *elemVarPtr = TclLookupArrayElement(interp, varName, sl@0: part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); sl@0: if ((elemVarPtr == NULL) || sl@0: (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, sl@0: part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) { sl@0: result = TCL_ERROR; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * The TclPtrSetVar call might have shimmered sl@0: * arrayElemObj to another type, so re-fetch sl@0: * the pointers for safety. sl@0: */ sl@0: Tcl_ListObjGetElements(NULL, arrayElemObj, sl@0: &elemLen, &elemPtrs); sl@0: } sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * The list is empty make sure we have an array, or create sl@0: * one if necessary. sl@0: */ sl@0: sl@0: if (varPtr != NULL) { sl@0: if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { sl@0: /* sl@0: * Already an array, done. sl@0: */ sl@0: sl@0: return TCL_OK; sl@0: } sl@0: if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) { sl@0: /* sl@0: * Either an array element, or a scalar: lose! sl@0: */ sl@0: sl@0: VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: TclSetVarArray(varPtr); sl@0: TclClearVarUndefined(varPtr); sl@0: varPtr->value.tablePtr = sl@0: (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ObjMakeUpvar -- sl@0: * sl@0: * This procedure does all of the work of the "global" and "upvar" sl@0: * commands. sl@0: * sl@0: * Results: sl@0: * A standard Tcl completion code. If an error occurs then an sl@0: * error message is left in iPtr->result. sl@0: * sl@0: * Side effects: sl@0: * The variable given by myName is linked to the variable in framePtr sl@0: * given by otherP1 and otherP2, so that references to myName are sl@0: * redirected to the other variable like a symbolic link. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index) sl@0: Tcl_Interp *interp; /* Interpreter containing variables. Used sl@0: * for error messages, too. */ sl@0: CallFrame *framePtr; /* Call frame containing "other" variable. sl@0: * NULL means use global :: context. */ sl@0: Tcl_Obj *otherP1Ptr; sl@0: CONST char *otherP2; /* Two-part name of variable in framePtr. */ sl@0: CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: sl@0: * indicates scope of "other" variable. */ sl@0: CONST char *myName; /* Name of variable which will refer to sl@0: * otherP1/otherP2. Must be a scalar. */ sl@0: int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: sl@0: * indicates scope of myName. */ sl@0: int index; /* If the variable to be linked is an indexed sl@0: * scalar, this is its index. Otherwise, -1. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Var *otherPtr, *varPtr, *arrayPtr; sl@0: CallFrame *varFramePtr; sl@0: CONST char *errMsg; sl@0: sl@0: /* sl@0: * Find "other" in "framePtr". If not looking up other in just the sl@0: * current namespace, temporarily replace the current var frame sl@0: * pointer in the interpreter in order to use TclObjLookupVar. sl@0: */ sl@0: sl@0: varFramePtr = iPtr->varFramePtr; sl@0: if (!(otherFlags & TCL_NAMESPACE_ONLY)) { sl@0: iPtr->varFramePtr = framePtr; sl@0: } sl@0: otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2, sl@0: (otherFlags | TCL_LEAVE_ERR_MSG), "access", sl@0: /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); sl@0: if (!(otherFlags & TCL_NAMESPACE_ONLY)) { sl@0: iPtr->varFramePtr = varFramePtr; sl@0: } sl@0: if (otherPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (index >= 0) { sl@0: if (!varFramePtr->isProcCallFrame) { sl@0: panic("ObjMakeUpvar called with an index outside from a proc.\n"); sl@0: } sl@0: varPtr = &(varFramePtr->compiledLocals[index]); sl@0: } else { sl@0: /* sl@0: * Check that we are not trying to create a namespace var linked to sl@0: * a local variable in a procedure. If we allowed this, the local sl@0: * variable in the shorter-lived procedure frame could go away sl@0: * leaving the namespace var's reference invalid. sl@0: */ sl@0: sl@0: if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) sl@0: && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) sl@0: || (varFramePtr == NULL) sl@0: || !varFramePtr->isProcCallFrame sl@0: || (strstr(myName, "::") != NULL))) { sl@0: Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", sl@0: myName, "\": upvar won't create namespace variable that ", sl@0: "refers to procedure variable", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Lookup and eventually create the new variable. Set the flag bit sl@0: * LOOKUP_FOR_UPVAR to indicate the special resolution rules for sl@0: * upvar purposes: sl@0: * - Bug #696893 - variable is either proc-local or in the current sl@0: * namespace; never follow the second (global) resolution path sl@0: * - Bug #631741 - do not use special namespace or interp resolvers sl@0: */ sl@0: sl@0: varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR), sl@0: /* create */ 1, &errMsg, &index); sl@0: if (varPtr == NULL) { sl@0: VarErrMsg(interp, myName, NULL, "create", errMsg); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: if (varPtr == otherPtr) { sl@0: Tcl_SetResult((Tcl_Interp *) iPtr, sl@0: "can't upvar from variable to itself", TCL_STATIC); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (varPtr->tracePtr != NULL) { sl@0: Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, sl@0: "\" has traces: can't use for upvar", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else if (!TclIsVarUndefined(varPtr)) { sl@0: /* sl@0: * The variable already existed. Make sure this variable "varPtr" sl@0: * isn't the same as "otherPtr" (avoid circular links). Also, if sl@0: * it's not an upvar then it's an error. If it is an upvar, then sl@0: * just disconnect it from the thing it currently refers to. sl@0: */ sl@0: sl@0: if (TclIsVarLink(varPtr)) { sl@0: Var *linkPtr = varPtr->value.linkPtr; sl@0: if (linkPtr == otherPtr) { sl@0: return TCL_OK; sl@0: } sl@0: linkPtr->refCount--; sl@0: if (TclIsVarUndefined(linkPtr)) { sl@0: CleanupVar(linkPtr, (Var *) NULL); sl@0: } sl@0: } else { sl@0: Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, sl@0: "\" already exists", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: TclSetVarLink(varPtr); sl@0: TclClearVarUndefined(varPtr); sl@0: varPtr->value.linkPtr = otherPtr; sl@0: otherPtr->refCount++; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UpVar -- sl@0: * sl@0: * This procedure links one variable to another, just like sl@0: * the "upvar" command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl completion code. If an error occurs then sl@0: * an error message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * The variable in frameName whose name is given by varName becomes sl@0: * accessible under the name localName, so that references to sl@0: * localName are redirected to the other variable like a symbolic sl@0: * link. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_UpVar(interp, frameName, varName, localName, flags) sl@0: Tcl_Interp *interp; /* Command interpreter in which varName is sl@0: * to be looked up. */ sl@0: CONST char *frameName; /* Name of the frame containing the source sl@0: * variable, such as "1" or "#0". */ sl@0: CONST char *varName; /* Name of a variable in interp to link to. sl@0: * May be either a scalar name or an sl@0: * element in an array. */ sl@0: CONST char *localName; /* Name of link variable. */ sl@0: int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: sl@0: * indicates scope of localName. */ sl@0: { sl@0: return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UpVar2 -- sl@0: * sl@0: * This procedure links one variable to another, just like sl@0: * the "upvar" command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl completion code. If an error occurs then sl@0: * an error message is left in the interp's result. sl@0: * sl@0: * Side effects: sl@0: * The variable in frameName whose name is given by part1 and sl@0: * part2 becomes accessible under the name localName, so that sl@0: * references to localName are redirected to the other variable sl@0: * like a symbolic link. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) sl@0: Tcl_Interp *interp; /* Interpreter containing variables. Used sl@0: * for error messages too. */ sl@0: CONST char *frameName; /* Name of the frame containing the source sl@0: * variable, such as "1" or "#0". */ sl@0: CONST char *part1; sl@0: CONST char *part2; /* Two parts of source variable name to sl@0: * link to. */ sl@0: CONST char *localName; /* Name of link variable. */ sl@0: int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: sl@0: * indicates scope of localName. */ sl@0: { sl@0: int result; sl@0: CallFrame *framePtr; sl@0: Tcl_Obj *part1Ptr; sl@0: sl@0: if (TclGetFrame(interp, frameName, &framePtr) == -1) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: part1Ptr = Tcl_NewStringObj(part1, -1); sl@0: Tcl_IncrRefCount(part1Ptr); sl@0: result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, sl@0: localName, flags, -1); sl@0: TclDecrRefCount(part1Ptr); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetVariableFullName -- sl@0: * sl@0: * Given a Tcl_Var token returned by Tcl_FindNamespaceVar, this sl@0: * procedure appends to an object the namespace variable's full sl@0: * name, qualified by a sequence of parent namespace names. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The variable's fully-qualified name is appended to the string sl@0: * representation of objPtr. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: Tcl_GetVariableFullName(interp, variable, objPtr) sl@0: Tcl_Interp *interp; /* Interpreter containing the variable. */ sl@0: Tcl_Var variable; /* Token for the variable returned by a sl@0: * previous call to Tcl_FindNamespaceVar. */ sl@0: Tcl_Obj *objPtr; /* Points to the object onto which the sl@0: * variable's full name is appended. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register Var *varPtr = (Var *) variable; sl@0: char *name; sl@0: sl@0: /* sl@0: * Add the full name of the containing namespace (if any), followed by sl@0: * the "::" separator, then the variable name. sl@0: */ sl@0: sl@0: if (varPtr != NULL) { sl@0: if (!TclIsVarArrayElement(varPtr)) { sl@0: if (varPtr->nsPtr != NULL) { sl@0: Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1); sl@0: if (varPtr->nsPtr != iPtr->globalNsPtr) { sl@0: Tcl_AppendToObj(objPtr, "::", 2); sl@0: } sl@0: } sl@0: if (varPtr->name != NULL) { sl@0: Tcl_AppendToObj(objPtr, varPtr->name, -1); sl@0: } else if (varPtr->hPtr != NULL) { sl@0: name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr); sl@0: Tcl_AppendToObj(objPtr, name, -1); sl@0: } sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GlobalObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "global" Tcl sl@0: * command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_GlobalObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: register Tcl_Obj *objPtr; sl@0: char *varName; sl@0: register char *tail; sl@0: int result, i; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If we are not executing inside a Tcl procedure, just return. sl@0: */ sl@0: sl@0: if ((iPtr->varFramePtr == NULL) sl@0: || !iPtr->varFramePtr->isProcCallFrame) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: for (i = 1; i < objc; i++) { sl@0: /* sl@0: * Make a local variable linked to its counterpart in the global :: sl@0: * namespace. sl@0: */ sl@0: sl@0: objPtr = objv[i]; sl@0: varName = TclGetString(objPtr); sl@0: sl@0: /* sl@0: * The variable name might have a scope qualifier, but the name for sl@0: * the local "link" variable must be the simple name at the tail. sl@0: */ sl@0: sl@0: for (tail = varName; *tail != '\0'; tail++) { sl@0: /* empty body */ sl@0: } sl@0: while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { sl@0: tail--; sl@0: } sl@0: if ((*tail == ':') && (tail > varName)) { sl@0: tail++; sl@0: } sl@0: sl@0: /* sl@0: * Link to the variable "varName" in the global :: namespace. sl@0: */ sl@0: sl@0: result = ObjMakeUpvar(interp, (CallFrame *) NULL, sl@0: objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, sl@0: /*myName*/ tail, /*myFlags*/ 0, -1); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_VariableObjCmd -- sl@0: * sl@0: * Invoked to implement the "variable" command that creates one or more sl@0: * global variables. Handles the following syntax: sl@0: * sl@0: * variable ?name value...? name ?value? sl@0: * sl@0: * One or more variables can be created. The variables are initialized sl@0: * with the specified values. The value for the last variable is sl@0: * optional. sl@0: * sl@0: * If the variable does not exist, it is created and given the optional sl@0: * value. If it already exists, it is simply set to the optional sl@0: * value. Normally, "name" is an unqualified name, so it is created in sl@0: * the current namespace. If it includes namespace qualifiers, it can sl@0: * be created in another namespace. sl@0: * sl@0: * If the variable command is executed inside a Tcl procedure, it sl@0: * creates a local variable linked to the newly-created namespace sl@0: * variable. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if the variable is found or created. Returns sl@0: * TCL_ERROR if anything goes wrong. sl@0: * sl@0: * Side effects: sl@0: * If anything goes wrong, this procedure returns an error message sl@0: * as the result in the interpreter's result object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_VariableObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: char *varName, *tail, *cp; sl@0: Var *varPtr, *arrayPtr; sl@0: Tcl_Obj *varValuePtr; sl@0: int i, result; sl@0: Tcl_Obj *varNamePtr; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: for (i = 1; i < objc; i = i+2) { sl@0: /* sl@0: * Look up each variable in the current namespace context, creating sl@0: * it if necessary. sl@0: */ sl@0: sl@0: varNamePtr = objv[i]; sl@0: varName = TclGetString(varNamePtr); sl@0: varPtr = TclObjLookupVar(interp, varNamePtr, NULL, sl@0: (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", sl@0: /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); sl@0: sl@0: if (arrayPtr != NULL) { sl@0: /* sl@0: * Variable cannot be an element in an array. If arrayPtr is sl@0: * non-null, it is, so throw up an error and return. sl@0: */ sl@0: VarErrMsg(interp, varName, NULL, "define", isArrayElement); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (varPtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Mark the variable as a namespace variable and increment its sl@0: * reference count so that it will persist until its namespace is sl@0: * destroyed or until the variable is unset. sl@0: */ sl@0: sl@0: if (!(varPtr->flags & VAR_NAMESPACE_VAR)) { sl@0: varPtr->flags |= VAR_NAMESPACE_VAR; sl@0: varPtr->refCount++; sl@0: } sl@0: sl@0: /* sl@0: * If a value was specified, set the variable to that value. sl@0: * Otherwise, if the variable is new, leave it undefined. sl@0: * (If the variable already exists and no value was specified, sl@0: * leave its value unchanged; just create the local link if sl@0: * we're in a Tcl procedure). sl@0: */ sl@0: sl@0: if (i+1 < objc) { /* a value was specified */ sl@0: varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL, sl@0: objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); sl@0: if (varValuePtr == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * If we are executing inside a Tcl procedure, create a local sl@0: * variable linked to the new namespace variable "varName". sl@0: */ sl@0: sl@0: if ((iPtr->varFramePtr != NULL) sl@0: && iPtr->varFramePtr->isProcCallFrame) { sl@0: /* sl@0: * varName might have a scope qualifier, but the name for the sl@0: * local "link" variable must be the simple name at the tail. sl@0: * sl@0: * Locate tail in one pass: drop any prefix after two *or more* sl@0: * consecutive ":" characters). sl@0: */ sl@0: sl@0: for (tail = cp = varName; *cp != '\0'; ) { sl@0: if (*cp++ == ':') { sl@0: while (*cp == ':') { sl@0: tail = ++cp; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Create a local link "tail" to the variable "varName" in the sl@0: * current namespace. sl@0: */ sl@0: sl@0: result = ObjMakeUpvar(interp, (CallFrame *) NULL, sl@0: /*otherP1*/ varNamePtr, /*otherP2*/ NULL, sl@0: /*otherFlags*/ TCL_NAMESPACE_ONLY, sl@0: /*myName*/ tail, /*myFlags*/ 0, -1); sl@0: if (result != TCL_OK) { sl@0: return result; sl@0: } sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_UpvarObjCmd -- sl@0: * sl@0: * This object-based procedure is invoked to process the "upvar" sl@0: * Tcl command. See the user documentation for details on what it does. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result value. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: int sl@0: Tcl_UpvarObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: CallFrame *framePtr; sl@0: char *frameSpec, *localName; sl@0: int result; sl@0: sl@0: if (objc < 3) { sl@0: upvarSyntax: sl@0: Tcl_WrongNumArgs(interp, 1, objv, sl@0: "?level? otherVar localVar ?otherVar localVar ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Find the call frame containing each of the "other variables" to be sl@0: * linked to. sl@0: */ sl@0: sl@0: frameSpec = TclGetString(objv[1]); sl@0: result = TclGetFrame(interp, frameSpec, &framePtr); sl@0: if (result == -1) { sl@0: return TCL_ERROR; sl@0: } sl@0: objc -= result+1; sl@0: if ((objc & 1) != 0) { sl@0: goto upvarSyntax; sl@0: } sl@0: objv += result+1; sl@0: sl@0: /* sl@0: * Iterate over each (other variable, local variable) pair. sl@0: * Divide the other variable name into two parts, then call sl@0: * MakeUpvar to do all the work of linking it to the local variable. sl@0: */ sl@0: sl@0: for ( ; objc > 0; objc -= 2, objv += 2) { sl@0: localName = TclGetString(objv[1]); sl@0: result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0], sl@0: NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1); sl@0: if (result != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DisposeTraceResult-- sl@0: * sl@0: * This procedure is called to dispose of the result returned from sl@0: * a trace procedure. The disposal method appropriate to the type sl@0: * of result is determined by flags. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The memory allocated for the trace result may be freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DisposeTraceResult(flags, result) sl@0: int flags; /* Indicates type of result to determine sl@0: * proper disposal method */ sl@0: char *result; /* The result returned from a trace sl@0: * procedure to be disposed */ sl@0: { sl@0: if (flags & TCL_TRACE_RESULT_DYNAMIC) { sl@0: ckfree(result); sl@0: } else if (flags & TCL_TRACE_RESULT_OBJECT) { sl@0: Tcl_DecrRefCount((Tcl_Obj *) result); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CallVarTraces -- sl@0: * sl@0: * This procedure is invoked to find and invoke relevant sl@0: * trace procedures associated with a particular operation on sl@0: * a variable. This procedure invokes traces both on the sl@0: * variable and on its containing array (where relevant). sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR sl@0: * if invocation of a trace procedure indicated an error. When sl@0: * TCL_ERROR is returned and leaveErrMsg is true, then the sl@0: * ::errorInfo variable of iPtr has information about the error sl@0: * appended to it. sl@0: * sl@0: * Side effects: sl@0: * Almost anything can happen, depending on trace; this procedure sl@0: * itself doesn't have any side effects. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) sl@0: Interp *iPtr; /* Interpreter containing variable. */ sl@0: register Var *arrayPtr; /* Pointer to array variable that contains sl@0: * the variable, or NULL if the variable sl@0: * isn't an element of an array. */ sl@0: Var *varPtr; /* Variable whose traces are to be sl@0: * invoked. */ sl@0: CONST char *part1; sl@0: CONST char *part2; /* Variable's two-part name. */ sl@0: int flags; /* Flags passed to trace procedures: sl@0: * indicates what's happening to variable, sl@0: * plus other stuff like TCL_GLOBAL_ONLY, sl@0: * or TCL_NAMESPACE_ONLY. */ sl@0: CONST int leaveErrMsg; /* If true, and one of the traces indicates an sl@0: * error, then leave an error message and stack sl@0: * trace information in *iPTr. */ sl@0: { sl@0: register VarTrace *tracePtr; sl@0: ActiveVarTrace active; sl@0: char *result; sl@0: CONST char *openParen, *p; sl@0: Tcl_DString nameCopy; sl@0: int copiedName; sl@0: int code = TCL_OK; sl@0: int disposeFlags = 0; sl@0: int saveErrFlags = iPtr->flags sl@0: & (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET); sl@0: sl@0: /* sl@0: * If there are already similar trace procedures active for the sl@0: * variable, don't call them again. sl@0: */ sl@0: sl@0: if (varPtr->flags & VAR_TRACE_ACTIVE) { sl@0: return code; sl@0: } sl@0: varPtr->flags |= VAR_TRACE_ACTIVE; sl@0: varPtr->refCount++; sl@0: if (arrayPtr != NULL) { sl@0: arrayPtr->refCount++; sl@0: } sl@0: sl@0: /* sl@0: * If the variable name hasn't been parsed into array name and sl@0: * element, do it here. If there really is an array element, sl@0: * make a copy of the original name so that NULLs can be sl@0: * inserted into it to separate the names (can't modify the name sl@0: * string in place, because the string might get used by the sl@0: * callbacks we invoke). sl@0: */ sl@0: sl@0: copiedName = 0; sl@0: if (part2 == NULL) { sl@0: for (p = part1; *p ; p++) { sl@0: if (*p == '(') { sl@0: openParen = p; sl@0: do { sl@0: p++; sl@0: } while (*p != '\0'); sl@0: p--; sl@0: if (*p == ')') { sl@0: int offset = (openParen - part1); sl@0: char *newPart1; sl@0: Tcl_DStringInit(&nameCopy); sl@0: Tcl_DStringAppend(&nameCopy, part1, (p-part1)); sl@0: newPart1 = Tcl_DStringValue(&nameCopy); sl@0: newPart1[offset] = 0; sl@0: part1 = newPart1; sl@0: part2 = newPart1 + offset + 1; sl@0: copiedName = 1; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke traces on the array containing the variable, if relevant. sl@0: */ sl@0: sl@0: result = NULL; sl@0: active.nextPtr = iPtr->activeVarTracePtr; sl@0: iPtr->activeVarTracePtr = &active; sl@0: Tcl_Preserve((ClientData) iPtr); sl@0: if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) { sl@0: active.varPtr = arrayPtr; sl@0: for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; sl@0: tracePtr = active.nextTracePtr) { sl@0: active.nextTracePtr = tracePtr->nextPtr; sl@0: if (!(tracePtr->flags & flags)) { sl@0: continue; sl@0: } sl@0: Tcl_Preserve((ClientData) tracePtr); sl@0: if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { sl@0: flags |= TCL_INTERP_DESTROYED; sl@0: } sl@0: result = (*tracePtr->traceProc)(tracePtr->clientData, sl@0: (Tcl_Interp *) iPtr, part1, part2, flags); sl@0: if (result != NULL) { sl@0: if (flags & TCL_TRACE_UNSETS) { sl@0: /* Ignore errors in unset traces */ sl@0: DisposeTraceResult(tracePtr->flags, result); sl@0: } else { sl@0: disposeFlags = tracePtr->flags; sl@0: code = TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_Release((ClientData) tracePtr); sl@0: if (code == TCL_ERROR) { sl@0: goto done; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke traces on the variable itself. sl@0: */ sl@0: sl@0: if (flags & TCL_TRACE_UNSETS) { sl@0: flags |= TCL_TRACE_DESTROYED; sl@0: } sl@0: active.varPtr = varPtr; sl@0: for (tracePtr = varPtr->tracePtr; tracePtr != NULL; sl@0: tracePtr = active.nextTracePtr) { sl@0: active.nextTracePtr = tracePtr->nextPtr; sl@0: if (!(tracePtr->flags & flags)) { sl@0: continue; sl@0: } sl@0: Tcl_Preserve((ClientData) tracePtr); sl@0: if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) { sl@0: flags |= TCL_INTERP_DESTROYED; sl@0: } sl@0: result = (*tracePtr->traceProc)(tracePtr->clientData, sl@0: (Tcl_Interp *) iPtr, part1, part2, flags); sl@0: if (result != NULL) { sl@0: if (flags & TCL_TRACE_UNSETS) { sl@0: /* Ignore errors in unset traces */ sl@0: DisposeTraceResult(tracePtr->flags, result); sl@0: } else { sl@0: disposeFlags = tracePtr->flags; sl@0: code = TCL_ERROR; sl@0: } sl@0: } sl@0: Tcl_Release((ClientData) tracePtr); sl@0: if (code == TCL_ERROR) { sl@0: goto done; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Restore the variable's flags, remove the record of our active sl@0: * traces, and then return. sl@0: */ sl@0: sl@0: done: sl@0: if (code == TCL_OK) { sl@0: iPtr->flags |= saveErrFlags; sl@0: } sl@0: if (code == TCL_ERROR) { sl@0: if (leaveErrMsg) { sl@0: CONST char *type = ""; sl@0: switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { sl@0: case TCL_TRACE_READS: { sl@0: type = "read"; sl@0: break; sl@0: } sl@0: case TCL_TRACE_WRITES: { sl@0: type = "set"; sl@0: break; sl@0: } sl@0: case TCL_TRACE_ARRAY: { sl@0: type = "trace array"; sl@0: break; sl@0: } sl@0: } sl@0: if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { sl@0: VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, sl@0: Tcl_GetString((Tcl_Obj *) result)); sl@0: } else { sl@0: VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); sl@0: } sl@0: } sl@0: DisposeTraceResult(disposeFlags,result); sl@0: } sl@0: sl@0: if (arrayPtr != NULL) { sl@0: arrayPtr->refCount--; sl@0: } sl@0: if (copiedName) { sl@0: Tcl_DStringFree(&nameCopy); sl@0: } sl@0: varPtr->flags &= ~VAR_TRACE_ACTIVE; sl@0: varPtr->refCount--; sl@0: iPtr->activeVarTracePtr = active.nextPtr; sl@0: Tcl_Release((ClientData) iPtr); sl@0: return code; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * NewVar -- sl@0: * sl@0: * Create a new heap-allocated variable that will eventually be sl@0: * entered into a hashtable. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the new variable structure. It is sl@0: * marked as a scalar variable (and not a link or array variable). Its sl@0: * value initially is NULL. The variable is not part of any hash table sl@0: * yet. Since it will be in a hashtable and not in a call frame, its sl@0: * name field is set NULL. It is initially marked as undefined. sl@0: * sl@0: * Side effects: sl@0: * Storage gets allocated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Var * sl@0: NewVar() sl@0: { sl@0: register Var *varPtr; sl@0: sl@0: varPtr = (Var *) ckalloc(sizeof(Var)); sl@0: varPtr->value.objPtr = NULL; sl@0: varPtr->name = NULL; sl@0: varPtr->nsPtr = NULL; sl@0: varPtr->hPtr = NULL; sl@0: varPtr->refCount = 0; sl@0: varPtr->tracePtr = NULL; sl@0: varPtr->searchPtr = NULL; sl@0: varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); sl@0: return varPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetArraySearchObj -- sl@0: * sl@0: * This function converts the given tcl object into one that sl@0: * has the "array search" internal type. sl@0: * sl@0: * Results: sl@0: * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed sl@0: * (when an error message will be placed in the interpreter's sl@0: * result.) sl@0: * sl@0: * Side effects: sl@0: * Updates the internal type and representation of the object to sl@0: * make this an array-search object. See the tclArraySearchType sl@0: * declaration above for details of the internal representation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetArraySearchObj(interp, objPtr) sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: char *string; sl@0: char *end; sl@0: int id; sl@0: size_t offset; sl@0: sl@0: /* sl@0: * Get the string representation. Make it up-to-date if necessary. sl@0: */ sl@0: sl@0: string = Tcl_GetString(objPtr); sl@0: sl@0: /* sl@0: * Parse the id into the three parts separated by dashes. sl@0: */ sl@0: if ((string[0] != 's') || (string[1] != '-')) { sl@0: syntax: sl@0: Tcl_AppendResult(interp, "illegal search identifier \"", string, sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: id = strtoul(string+2, &end, 10); sl@0: if ((end == (string+2)) || (*end != '-')) { sl@0: goto syntax; sl@0: } sl@0: /* sl@0: * Can't perform value check in this context, so place reference sl@0: * to place in string to use for the check in the object instead. sl@0: */ sl@0: end++; sl@0: offset = end - string; sl@0: sl@0: if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { sl@0: objPtr->typePtr->freeIntRepProc(objPtr); sl@0: } sl@0: objPtr->typePtr = &tclArraySearchType; sl@0: objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id); sl@0: objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ParseSearchId -- sl@0: * sl@0: * This procedure translates from a tcl object to a pointer to an sl@0: * active array search (if there is one that matches the string). sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the array search indicated sl@0: * by string, or NULL if there isn't one. If NULL is returned, sl@0: * the interp's result contains an error message. sl@0: * sl@0: * Side effects: sl@0: * The tcl object might have its internal type and representation sl@0: * modified. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static ArraySearch * sl@0: ParseSearchId(interp, varPtr, varName, handleObj) sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST Var *varPtr; /* Array variable search is for. */ sl@0: CONST char *varName; /* Name of array variable that search is sl@0: * supposed to be for. */ sl@0: Tcl_Obj *handleObj; /* Object containing id of search. Must have sl@0: * form "search-num-var" where "num" is a sl@0: * decimal number and "var" is a variable sl@0: * name. */ sl@0: { sl@0: register char *string; sl@0: register size_t offset; sl@0: int id; sl@0: ArraySearch *searchPtr; sl@0: sl@0: /* sl@0: * Parse the id. sl@0: */ sl@0: if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: /* sl@0: * Cast is safe, since always came from an int in the first place. sl@0: */ sl@0: id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - sl@0: ((char*)NULL)); sl@0: string = Tcl_GetString(handleObj); sl@0: offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - sl@0: ((char*)NULL)); sl@0: /* sl@0: * This test cannot be placed inside the Tcl_Obj machinery, since sl@0: * it is dependent on the variable context. sl@0: */ sl@0: if (strcmp(string+offset, varName) != 0) { sl@0: Tcl_AppendResult(interp, "search identifier \"", string, sl@0: "\" isn't for variable \"", varName, "\"", (char *) NULL); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Search through the list of active searches on the interpreter sl@0: * to see if the desired one exists. sl@0: * sl@0: * Note that we cannot store the searchPtr directly in the Tcl_Obj sl@0: * as that would run into trouble when DeleteSearches() was called sl@0: * so we must scan this list every time. sl@0: */ sl@0: sl@0: for (searchPtr = varPtr->searchPtr; searchPtr != NULL; sl@0: searchPtr = searchPtr->nextPtr) { sl@0: if (searchPtr->id == id) { sl@0: return searchPtr; sl@0: } sl@0: } sl@0: Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", sl@0: (char *) NULL); sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteSearches -- sl@0: * sl@0: * This procedure is called to free up all of the searches sl@0: * associated with an array variable. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Memory is released to the storage allocator. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DeleteSearches(arrayVarPtr) sl@0: register Var *arrayVarPtr; /* Variable whose searches are sl@0: * to be deleted. */ sl@0: { sl@0: ArraySearch *searchPtr; sl@0: sl@0: while (arrayVarPtr->searchPtr != NULL) { sl@0: searchPtr = arrayVarPtr->searchPtr; sl@0: arrayVarPtr->searchPtr = searchPtr->nextPtr; sl@0: ckfree((char *) searchPtr); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclDeleteNamespaceVars -- sl@0: * sl@0: * This procedure is called to recycle all the storage space sl@0: * associated with a namespace's table of variables. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Variables are deleted and trace procedures are invoked, if sl@0: * any are declared. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclDeleteNamespaceVars(nsPtr) sl@0: Namespace *nsPtr; sl@0: { sl@0: Tcl_HashTable *tablePtr = &nsPtr->varTable; sl@0: Tcl_Interp *interp = nsPtr->interp; sl@0: Interp *iPtr = (Interp *)interp; sl@0: Tcl_HashSearch search; sl@0: Tcl_HashEntry *hPtr; sl@0: int flags = 0; sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: sl@0: /* sl@0: * Determine what flags to pass to the trace callback procedures. sl@0: */ sl@0: sl@0: if (nsPtr == iPtr->globalNsPtr) { sl@0: flags = TCL_GLOBAL_ONLY; sl@0: } else if (nsPtr == currNsPtr) { sl@0: flags = TCL_NAMESPACE_ONLY; sl@0: } sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; sl@0: hPtr = Tcl_FirstHashEntry(tablePtr, &search)) { sl@0: register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr); sl@0: Tcl_Obj *objPtr = Tcl_NewObj(); sl@0: varPtr->refCount++; /* Make sure we get to remove from hash */ sl@0: Tcl_IncrRefCount(objPtr); sl@0: Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); sl@0: UnsetVarStruct(varPtr, NULL, iPtr, Tcl_GetString(objPtr), NULL, flags); sl@0: Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ sl@0: varPtr->refCount--; sl@0: sl@0: /* Remove the variable from the table and force it undefined sl@0: * in case an unset trace brought it back from the dead */ sl@0: Tcl_DeleteHashEntry(hPtr); sl@0: varPtr->hPtr = NULL; sl@0: TclSetVarUndefined(varPtr); sl@0: TclSetVarScalar(varPtr); sl@0: while (varPtr->tracePtr != NULL) { sl@0: VarTrace *tracePtr = varPtr->tracePtr; sl@0: varPtr->tracePtr = tracePtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); sl@0: } sl@0: CleanupVar(varPtr, NULL); sl@0: } sl@0: Tcl_DeleteHashTable(tablePtr); sl@0: } sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclDeleteVars -- sl@0: * sl@0: * This procedure is called to recycle all the storage space sl@0: * associated with a table of variables. For this procedure sl@0: * to work correctly, it must not be possible for any of the sl@0: * variables in the table to be accessed from Tcl commands sl@0: * (e.g. from trace procedures). sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Variables are deleted and trace procedures are invoked, if sl@0: * any are declared. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclDeleteVars(iPtr, tablePtr) sl@0: Interp *iPtr; /* Interpreter to which variables belong. */ sl@0: Tcl_HashTable *tablePtr; /* Hash table containing variables to sl@0: * delete. */ sl@0: { sl@0: Tcl_Interp *interp = (Tcl_Interp *) iPtr; sl@0: Tcl_HashSearch search; sl@0: Tcl_HashEntry *hPtr; sl@0: register Var *varPtr; sl@0: Var *linkPtr; sl@0: int flags; sl@0: ActiveVarTrace *activePtr; sl@0: Tcl_Obj *objPtr; sl@0: Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); sl@0: sl@0: /* sl@0: * Determine what flags to pass to the trace callback procedures. sl@0: */ sl@0: sl@0: flags = TCL_TRACE_UNSETS; sl@0: if (tablePtr == &iPtr->globalNsPtr->varTable) { sl@0: flags |= TCL_GLOBAL_ONLY; sl@0: } else if (tablePtr == &currNsPtr->varTable) { sl@0: flags |= TCL_NAMESPACE_ONLY; sl@0: } sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; sl@0: hPtr = Tcl_NextHashEntry(&search)) { sl@0: varPtr = (Var *) Tcl_GetHashValue(hPtr); sl@0: sl@0: /* sl@0: * For global/upvar variables referenced in procedures, decrement sl@0: * the reference count on the variable referred to, and free sl@0: * the referenced variable if it's no longer needed. Don't delete sl@0: * the hash entry for the other variable if it's in the same table sl@0: * as us: this will happen automatically later on. sl@0: */ sl@0: sl@0: if (TclIsVarLink(varPtr)) { sl@0: linkPtr = varPtr->value.linkPtr; sl@0: linkPtr->refCount--; sl@0: if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) sl@0: && (linkPtr->tracePtr == NULL) sl@0: && (linkPtr->flags & VAR_IN_HASHTABLE)) { sl@0: if (linkPtr->hPtr == NULL) { sl@0: ckfree((char *) linkPtr); sl@0: } else if (linkPtr->hPtr->tablePtr != tablePtr) { sl@0: Tcl_DeleteHashEntry(linkPtr->hPtr); sl@0: ckfree((char *) linkPtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke traces on the variable that is being deleted, then sl@0: * free up the variable's space (no need to free the hash entry sl@0: * here, unless we're dealing with a global variable: the sl@0: * hash entries will be deleted automatically when the whole sl@0: * table is deleted). Note that we give CallVarTraces the variable's sl@0: * fully-qualified name so that any called trace procedures can sl@0: * refer to these variables being deleted. sl@0: */ sl@0: sl@0: if (varPtr->tracePtr != NULL) { sl@0: objPtr = Tcl_NewObj(); sl@0: Tcl_IncrRefCount(objPtr); /* until done with traces */ sl@0: Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); sl@0: CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), sl@0: NULL, flags, /* leaveErrMsg */ 0); sl@0: Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ sl@0: sl@0: while (varPtr->tracePtr != NULL) { sl@0: VarTrace *tracePtr = varPtr->tracePtr; sl@0: varPtr->tracePtr = tracePtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); sl@0: } sl@0: for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->varPtr == varPtr) { sl@0: activePtr->nextTracePtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (TclIsVarArray(varPtr)) { sl@0: DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, sl@0: flags); sl@0: varPtr->value.tablePtr = NULL; sl@0: } sl@0: if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { sl@0: objPtr = varPtr->value.objPtr; sl@0: TclDecrRefCount(objPtr); sl@0: varPtr->value.objPtr = NULL; sl@0: } sl@0: varPtr->hPtr = NULL; sl@0: varPtr->tracePtr = NULL; sl@0: TclSetVarUndefined(varPtr); sl@0: TclSetVarScalar(varPtr); sl@0: sl@0: /* sl@0: * If the variable was a namespace variable, decrement its sl@0: * reference count. We are in the process of destroying its sl@0: * namespace so that namespace will no longer "refer" to the sl@0: * variable. sl@0: */ sl@0: sl@0: if (varPtr->flags & VAR_NAMESPACE_VAR) { sl@0: varPtr->flags &= ~VAR_NAMESPACE_VAR; sl@0: varPtr->refCount--; sl@0: } sl@0: sl@0: /* sl@0: * Recycle the variable's memory space if there aren't any upvar's sl@0: * pointing to it. If there are upvars to this variable, then the sl@0: * variable will get freed when the last upvar goes away. sl@0: */ sl@0: sl@0: if (varPtr->refCount == 0) { sl@0: ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */ sl@0: } sl@0: } sl@0: Tcl_DeleteHashTable(tablePtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclDeleteCompiledLocalVars -- sl@0: * sl@0: * This procedure is called to recycle storage space associated with sl@0: * the compiler-allocated array of local variables in a procedure call sl@0: * frame. This procedure resembles TclDeleteVars above except that each sl@0: * variable is stored in a call frame and not a hash table. For this sl@0: * procedure to work correctly, it must not be possible for any of the sl@0: * variable in the table to be accessed from Tcl commands (e.g. from sl@0: * trace procedures). sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Variables are deleted and trace procedures are invoked, if sl@0: * any are declared. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclDeleteCompiledLocalVars(iPtr, framePtr) sl@0: Interp *iPtr; /* Interpreter to which variables belong. */ sl@0: CallFrame *framePtr; /* Procedure call frame containing sl@0: * compiler-assigned local variables to sl@0: * delete. */ sl@0: { sl@0: register Var *varPtr; sl@0: int flags; /* Flags passed to trace procedures. */ sl@0: Var *linkPtr; sl@0: ActiveVarTrace *activePtr; sl@0: int numLocals, i; sl@0: sl@0: flags = TCL_TRACE_UNSETS; sl@0: numLocals = framePtr->numCompiledLocals; sl@0: varPtr = framePtr->compiledLocals; sl@0: for (i = 0; i < numLocals; i++) { sl@0: /* sl@0: * For global/upvar variables referenced in procedures, decrement sl@0: * the reference count on the variable referred to, and free sl@0: * the referenced variable if it's no longer needed. Don't delete sl@0: * the hash entry for the other variable if it's in the same table sl@0: * as us: this will happen automatically later on. sl@0: */ sl@0: sl@0: if (TclIsVarLink(varPtr)) { sl@0: linkPtr = varPtr->value.linkPtr; sl@0: linkPtr->refCount--; sl@0: if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) sl@0: && (linkPtr->tracePtr == NULL) sl@0: && (linkPtr->flags & VAR_IN_HASHTABLE)) { sl@0: if (linkPtr->hPtr == NULL) { sl@0: ckfree((char *) linkPtr); sl@0: } else { sl@0: Tcl_DeleteHashEntry(linkPtr->hPtr); sl@0: ckfree((char *) linkPtr); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke traces on the variable that is being deleted. Then delete sl@0: * the variable's trace records. sl@0: */ sl@0: sl@0: if (varPtr->tracePtr != NULL) { sl@0: CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL, sl@0: flags, /* leaveErrMsg */ 0); sl@0: while (varPtr->tracePtr != NULL) { sl@0: VarTrace *tracePtr = varPtr->tracePtr; sl@0: varPtr->tracePtr = tracePtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); sl@0: } sl@0: for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->varPtr == varPtr) { sl@0: activePtr->nextTracePtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Now if the variable is an array, delete its element hash table. sl@0: * Otherwise, if it's a scalar variable, decrement the ref count sl@0: * of its value. sl@0: */ sl@0: sl@0: if (TclIsVarArray(varPtr) && (varPtr->value.tablePtr != NULL)) { sl@0: DeleteArray(iPtr, varPtr->name, varPtr, flags); sl@0: } sl@0: if (TclIsVarScalar(varPtr) && (varPtr->value.objPtr != NULL)) { sl@0: TclDecrRefCount(varPtr->value.objPtr); sl@0: varPtr->value.objPtr = NULL; sl@0: } sl@0: varPtr->hPtr = NULL; sl@0: varPtr->tracePtr = NULL; sl@0: TclSetVarUndefined(varPtr); sl@0: TclSetVarScalar(varPtr); sl@0: varPtr++; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteArray -- sl@0: * sl@0: * This procedure is called to free up everything in an array sl@0: * variable. It's the caller's responsibility to make sure sl@0: * that the array is no longer accessible before this procedure sl@0: * is called. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * All storage associated with varPtr's array elements is deleted sl@0: * (including the array's hash table). Deletion trace procedures for sl@0: * array elements are invoked, then deleted. Any pending traces for sl@0: * array elements are also deleted. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DeleteArray(iPtr, arrayName, varPtr, flags) sl@0: Interp *iPtr; /* Interpreter containing array. */ sl@0: CONST char *arrayName; /* Name of array (used for trace sl@0: * callbacks). */ sl@0: Var *varPtr; /* Pointer to variable structure. */ sl@0: int flags; /* Flags to pass to CallVarTraces: sl@0: * TCL_TRACE_UNSETS and sometimes sl@0: * TCL_NAMESPACE_ONLY, or sl@0: * TCL_GLOBAL_ONLY. */ sl@0: { sl@0: Tcl_HashSearch search; sl@0: register Tcl_HashEntry *hPtr; sl@0: register Var *elPtr; sl@0: ActiveVarTrace *activePtr; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: DeleteSearches(varPtr); sl@0: for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: elPtr = (Var *) Tcl_GetHashValue(hPtr); sl@0: if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { sl@0: objPtr = elPtr->value.objPtr; sl@0: TclDecrRefCount(objPtr); sl@0: elPtr->value.objPtr = NULL; sl@0: } sl@0: elPtr->hPtr = NULL; sl@0: if (elPtr->tracePtr != NULL) { sl@0: elPtr->flags &= ~VAR_TRACE_ACTIVE; sl@0: CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, sl@0: Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, sl@0: /* leaveErrMsg */ 0); sl@0: while (elPtr->tracePtr != NULL) { sl@0: VarTrace *tracePtr = elPtr->tracePtr; sl@0: elPtr->tracePtr = tracePtr->nextPtr; sl@0: Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC); sl@0: } sl@0: for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; sl@0: activePtr = activePtr->nextPtr) { sl@0: if (activePtr->varPtr == elPtr) { sl@0: activePtr->nextTracePtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: TclSetVarUndefined(elPtr); sl@0: TclSetVarScalar(elPtr); sl@0: sl@0: /* sl@0: * Even though array elements are not supposed to be namespace sl@0: * variables, some combinations of [upvar] and [variable] may sl@0: * create such beasts - see [Bug 604239]. This is necessary to sl@0: * avoid leaking the corresponding Var struct, and is otherwise sl@0: * harmless. sl@0: */ sl@0: sl@0: if (elPtr->flags & VAR_NAMESPACE_VAR) { sl@0: elPtr->flags &= ~VAR_NAMESPACE_VAR; sl@0: elPtr->refCount--; sl@0: } sl@0: if (elPtr->refCount == 0) { sl@0: ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ sl@0: } sl@0: } sl@0: Tcl_DeleteHashTable(varPtr->value.tablePtr); sl@0: ckfree((char *) varPtr->value.tablePtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * CleanupVar -- sl@0: * sl@0: * This procedure is called when it looks like it may be OK to free up sl@0: * a variable's storage. If the variable is in a hashtable, its Var sl@0: * structure and hash table entry will be freed along with those of its sl@0: * containing array, if any. This procedure is called, for example, sl@0: * when a trace on a variable deletes a variable. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * If the variable (or its containing array) really is dead and in a sl@0: * hashtable, then its Var structure, and possibly its hash table sl@0: * entry, is freed up. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: CleanupVar(varPtr, arrayPtr) sl@0: Var *varPtr; /* Pointer to variable that may be a sl@0: * candidate for being expunged. */ sl@0: Var *arrayPtr; /* Array that contains the variable, or sl@0: * NULL if this variable isn't an array sl@0: * element. */ sl@0: { sl@0: if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) sl@0: && (varPtr->tracePtr == NULL) sl@0: && (varPtr->flags & VAR_IN_HASHTABLE)) { sl@0: if (varPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(varPtr->hPtr); sl@0: } sl@0: ckfree((char *) varPtr); sl@0: } sl@0: if (arrayPtr != NULL) { sl@0: if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) sl@0: && (arrayPtr->tracePtr == NULL) sl@0: && (arrayPtr->flags & VAR_IN_HASHTABLE)) { sl@0: if (arrayPtr->hPtr != NULL) { sl@0: Tcl_DeleteHashEntry(arrayPtr->hPtr); sl@0: } sl@0: ckfree((char *) arrayPtr); sl@0: } sl@0: } sl@0: } sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * VarErrMsg -- sl@0: * sl@0: * Generate a reasonable error message describing why a variable sl@0: * operation failed. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The interp's result is set to hold a message identifying the sl@0: * variable given by part1 and part2 and describing why the sl@0: * variable operation failed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: VarErrMsg(interp, part1, part2, operation, reason) sl@0: Tcl_Interp *interp; /* Interpreter in which to record message. */ sl@0: CONST char *part1; sl@0: CONST char *part2; /* Variable's two-part name. */ sl@0: CONST char *operation; /* String describing operation that failed, sl@0: * e.g. "read", "set", or "unset". */ sl@0: CONST char *reason; /* String describing why operation failed. */ sl@0: { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendResult(interp, "can't ", operation, " \"", part1, sl@0: (char *) NULL); sl@0: if (part2 != NULL) { sl@0: Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL); sl@0: } sl@0: Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclTraceVarExists -- sl@0: * sl@0: * This is called from info exists. We need to trigger read sl@0: * and/or array traces because they may end up creating a sl@0: * variable that doesn't currently exist. sl@0: * sl@0: * Results: sl@0: * A pointer to the Var structure, or NULL. sl@0: * sl@0: * Side effects: sl@0: * May fill in error messages in the interp. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: Var * sl@0: TclVarTraceExists(interp, varName) sl@0: Tcl_Interp *interp; /* The interpreter */ sl@0: CONST char *varName; /* The variable name */ sl@0: { sl@0: Var *varPtr; sl@0: Var *arrayPtr; sl@0: sl@0: /* sl@0: * The choice of "create" flag values is delicate here, and sl@0: * matches the semantics of GetVar. Things are still not perfect, sl@0: * however, because if you do "info exists x" you get a varPtr sl@0: * and therefore trigger traces. However, if you do sl@0: * "info exists x(i)", then you only get a varPtr if x is already sl@0: * known to be an array. Otherwise you get NULL, and no trace sl@0: * is triggered. This matches Tcl 7.6 semantics. sl@0: */ sl@0: sl@0: varPtr = TclLookupVar(interp, varName, (char *) NULL, sl@0: 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); sl@0: sl@0: if (varPtr == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: if ((varPtr->tracePtr != NULL) sl@0: || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { sl@0: CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, sl@0: TCL_TRACE_READS, /* leaveErrMsg */ 0); sl@0: } sl@0: sl@0: /* sl@0: * If the variable doesn't exist anymore and no-one's using sl@0: * it, then free up the relevant structures and hash table entries. sl@0: */ sl@0: sl@0: if (TclIsVarUndefined(varPtr)) { sl@0: CleanupVar(varPtr, arrayPtr); sl@0: return NULL; sl@0: } sl@0: sl@0: return varPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Internal functions for variable name object types -- sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* sl@0: * localVarName - sl@0: * sl@0: * INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1 = pointer to the corresponding Proc sl@0: * twoPtrValue.ptr2 = index into locals table sl@0: */ sl@0: sl@0: static void sl@0: FreeLocalVarName(objPtr) sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: procPtr->refCount--; sl@0: if (procPtr->refCount <= 0) { sl@0: TclProcCleanupProc(procPtr); sl@0: } sl@0: } sl@0: sl@0: static void sl@0: DupLocalVarName(srcPtr, dupPtr) sl@0: Tcl_Obj *srcPtr; sl@0: Tcl_Obj *dupPtr; sl@0: { sl@0: register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; sl@0: sl@0: dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; sl@0: dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2; sl@0: procPtr->refCount++; sl@0: dupPtr->typePtr = &tclLocalVarNameType; sl@0: } sl@0: sl@0: static void sl@0: UpdateLocalVarName(objPtr) sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2; sl@0: CompiledLocal *localPtr = procPtr->firstLocalPtr; sl@0: unsigned int nameLen; sl@0: sl@0: if (localPtr == NULL) { sl@0: goto emptyName; sl@0: } sl@0: while (index--) { sl@0: localPtr = localPtr->nextPtr; sl@0: if (localPtr == NULL) { sl@0: goto emptyName; sl@0: } sl@0: } sl@0: sl@0: nameLen = (unsigned int) localPtr->nameLength; sl@0: objPtr->bytes = ckalloc(nameLen + 1); sl@0: memcpy(objPtr->bytes, localPtr->name, nameLen + 1); sl@0: objPtr->length = nameLen; sl@0: return; sl@0: sl@0: emptyName: sl@0: objPtr->bytes = ckalloc(1); sl@0: *(objPtr->bytes) = '\0'; sl@0: objPtr->length = 0; sl@0: } sl@0: sl@0: /* sl@0: * nsVarName - sl@0: * sl@0: * INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1: pointer to the namespace containing the sl@0: * reference. sl@0: * twoPtrValue.ptr2: pointer to the corresponding Var sl@0: */ sl@0: sl@0: static void sl@0: FreeNsVarName(objPtr) sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2; sl@0: sl@0: varPtr->refCount--; sl@0: if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) { sl@0: if (TclIsVarLink(varPtr)) { sl@0: Var *linkPtr = varPtr->value.linkPtr; sl@0: linkPtr->refCount--; sl@0: if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) { sl@0: CleanupVar(linkPtr, (Var *) NULL); sl@0: } sl@0: } sl@0: CleanupVar(varPtr, NULL); sl@0: } sl@0: } sl@0: sl@0: static void sl@0: DupNsVarName(srcPtr, dupPtr) sl@0: Tcl_Obj *srcPtr; sl@0: Tcl_Obj *dupPtr; sl@0: { sl@0: Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1; sl@0: register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2; sl@0: sl@0: dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; sl@0: dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; sl@0: varPtr->refCount++; sl@0: dupPtr->typePtr = &tclNsVarNameType; sl@0: } sl@0: sl@0: /* sl@0: * parsedVarName - sl@0: * sl@0: * INTERNALREP DEFINITION: sl@0: * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj sl@0: * (NULL if scalar) sl@0: * twoPtrValue.ptr2 = pointer to the element name string sl@0: * (owned by this Tcl_Obj), or NULL if sl@0: * it is a scalar variable sl@0: */ sl@0: sl@0: static void sl@0: FreeParsedVarName(objPtr) sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: register Tcl_Obj *arrayPtr = sl@0: (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2; sl@0: sl@0: if (arrayPtr != NULL) { sl@0: TclDecrRefCount(arrayPtr); sl@0: ckfree(elem); sl@0: } sl@0: } sl@0: sl@0: static void sl@0: DupParsedVarName(srcPtr, dupPtr) sl@0: Tcl_Obj *srcPtr; sl@0: Tcl_Obj *dupPtr; sl@0: { sl@0: register Tcl_Obj *arrayPtr = sl@0: (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1; sl@0: register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2; sl@0: char *elemCopy; sl@0: unsigned int elemLen; sl@0: sl@0: if (arrayPtr != NULL) { sl@0: Tcl_IncrRefCount(arrayPtr); sl@0: elemLen = strlen(elem); sl@0: elemCopy = ckalloc(elemLen+1); sl@0: memcpy(elemCopy, elem, elemLen); sl@0: *(elemCopy + elemLen) = '\0'; sl@0: elem = elemCopy; sl@0: } sl@0: sl@0: dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr; sl@0: dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem; sl@0: dupPtr->typePtr = &tclParsedVarNameType; sl@0: } sl@0: sl@0: static void sl@0: UpdateParsedVarName(objPtr) sl@0: Tcl_Obj *objPtr; sl@0: { sl@0: Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; sl@0: char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2; sl@0: char *part1, *p; sl@0: int len1, len2, totalLen; sl@0: sl@0: if (arrayPtr == NULL) { sl@0: /* sl@0: * This is a parsed scalar name: what is it sl@0: * doing here? sl@0: */ sl@0: panic("ERROR: scalar parsedVarName without a string rep.\n"); sl@0: } sl@0: part1 = Tcl_GetStringFromObj(arrayPtr, &len1); sl@0: len2 = strlen(part2); sl@0: sl@0: totalLen = len1 + len2 + 2; sl@0: p = ckalloc((unsigned int) totalLen + 1); sl@0: objPtr->bytes = p; sl@0: objPtr->length = totalLen; sl@0: sl@0: memcpy(p, part1, (unsigned int) len1); sl@0: p += len1; sl@0: *p++ = '('; sl@0: memcpy(p, part2, (unsigned int) len2); sl@0: p += len2; sl@0: *p++ = ')'; sl@0: *p = '\0'; sl@0: }