Tcl Source Code

			    Tcl_HashSearch *searchPtr);
static inline Var *	VarHashNextVar(Tcl_HashSearch *searchPtr);
static inline void	CleanupVar(Var *varPtr, Var *arrayPtr);

#define VarHashGetValue(hPtr) \
    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))

/*
 * NOTE: VarHashCreateVar increments the recount of its key argument.
 * All callers that will call Tcl_DecrRefCount on that argument must
 * call Tcl_IncrRefCount on it before passing it in.  This requirement
 * can bubble up to callers of callers .... etc.
 */

static inline Var *
VarHashCreateVar(
    TclVarHashTable *tablePtr,
    Tcl_Obj *key,
    int *newPtr)
{
    Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,

				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr)		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{

    Var *varPtr;
    Tcl_Obj *part1Ptr = Tcl_NewStringObj(part1, -1);

    if (createPart1) {
	Tcl_IncrRefCount(part1Ptr);
    }

    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg,
	    createPart1, createPart2, arrayPtrPtr);

    TclDecrRefCount(part1Ptr);
    return varPtr;
}

 *	VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1. The object part1Ptr is converted to one of localVarNameType,
 *	tclNsVarNameType or tclParsedVarNameType and caches as much of the
 *	lookup as it can.
 *	When createPart1 is 1, callers must IncrRefCount part1Ptr if they
 *	plan to DecrRefCount it.
 *
 *----------------------------------------------------------------------
 */

Var *
TclObjLookupVar(
    Tcl_Interp *interp,		/* Interpreter to use for lookup. */

				 * name, if it doesn't already exist. If 0,
				 * return error if it doesn't exist. */
    Var **arrayPtrPtr)		/* If the name refers to an element of an
				 * array, *arrayPtrPtr gets filled in with
				 * address of array variable. Otherwise this
				 * is set to NULL. */
{
    Tcl_Obj *part2Ptr = NULL;
    Var *resPtr;

    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);



    }

    resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
	    flags, msg, createPart1, createPart2, arrayPtrPtr);

    if (part2Ptr) {
	Tcl_DecrRefCount(part2Ptr);

 *	if create is 1 (this only causes the hash table entry to be created).
 *	For example, the variable might be a global that has been unset but is
 *	still referenced by a procedure, or a variable that has been unset but
 *	it only being kept in existence (if VAR_UNDEFINED) by a trace.
 *
 * Side effects:
 *	A new hashtable entry may be created if create is 1.
 *	Callers must Incr varNamePtr if they plan to Decr it if create is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupSimpleVar(
    Tcl_Interp *interp,		/* Interpreter to use for lookup. */

    const char *part1,		/* Name of an array (if part2 is non-NULL) or
				 * the name of a variable. */
    const char *part2,		/* If non-NULL, gives the name of an element
				 * in the array part1. */
    int flags)			/* OR-ed combination of TCL_GLOBAL_ONLY, and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);



    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);



    }

    resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
	Tcl_DecrRefCount(part2Ptr);

				 * NULL. */
    const char *newValue,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
				 * TCL_LEAVE_ERR_MSG. */
{

    Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, part1, part2,






	    Tcl_NewStringObj(newValue, -1), flags);




    if (varValuePtr == NULL) {
	return NULL;
    }
    return TclGetString(varValuePtr);
}


				 * in the array part1. */
    Tcl_Obj *newValuePtr,	/* New value for variable. */
    int flags)			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or
				 * TCL_LEAVE_ERR_MSG. */
{
    Tcl_Obj *resPtr, *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);


    Tcl_IncrRefCount(part1Ptr);
    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);
	Tcl_IncrRefCount(part2Ptr);


    }

    resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
	Tcl_DecrRefCount(part2Ptr);

 *	left in the interpreter's result. Note that the returned object may
 *	not be the same one referenced by newValuePtr; this is because
 *	variable traces may modify the variable's value.
 *
 * Side effects:
 *	The value of the given variable is set. If either the array or the
 *	entry didn't exist then a new variable is created.
 *	Callers must Incr part1Ptr if they plan to Decr it.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjSetVar2(
    Tcl_Interp *interp,		/* Command interpreter in which variable is to

 *
 * Side effects:
 *	The value of the given variable is incremented by the specified
 *	amount. If either the array or the entry didn't exist then a new
 *	variable is created. The ref count for the returned object is _not_
 *	incremented to reflect the returned reference; if you want to keep a
 *	reference to the object you must increment its ref count yourself.
 *	Callers must Incr part1Ptr if they plan to Decr it.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclIncrObjVar2(
    Tcl_Interp *interp,		/* Command interpreter in which variable is to

				 * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
				 * TCL_LEAVE_ERR_MSG. */
    int index)			/* Index into the local variable table of the
				 * variable, or -1. Only used when part1Ptr is
				 * NULL. */
{
    register Tcl_Obj *varValuePtr;


    if (TclIsVarInHash(varPtr)) {
	VarHashRefCount(varPtr)++;
    }
    varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
	    flags, index);
    if (TclIsVarInHash(varPtr)) {
	VarHashRefCount(varPtr)--;
    }
    if (varValuePtr == NULL) {
	varValuePtr = Tcl_NewIntObj(0);
    }
    if (Tcl_IsShared(varValuePtr)) {
	/* Copy on write */
	varValuePtr = Tcl_DuplicateObj(varValuePtr);


	
	if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {

	    return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
		    varValuePtr, flags, index);
	} else {
	    Tcl_DecrRefCount(varValuePtr);
	    return NULL;
	}
    } else {
	/* Unshared - can Incr in place */
	if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {

	    /*
	     * This seems dumb to write the incremeted value into the var
	     * after we just adjusted the value in place, but the spec for
	     * [incr] requires that write traces fire, and making this call
	     * is the way to make that happen.
	     */

	    return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
		    varValuePtr, flags, index);
	} else {
	    return NULL;
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *

    const char *part1,		/* Name of variable or array. */
    const char *part2,		/* Name of element within array or NULL. */
    int flags)			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * TCL_LEAVE_ERR_MSG. */
{
    int result;
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);



    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);

    }

    /*
     * Filter to pass through only the flags this interface supports.
     */

    flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);

 *	TclSetupEnv routine.
 *
 * Results:
 *	A standard Tcl result object.
 *
 * Side effects:
 *	A variable will be created if one does not already exist.
 *	Callers must Incr arrayNameObj if they pland to Decr it.
 *
 *----------------------------------------------------------------------
 */

int
TclArraySet(
    Tcl_Interp *interp,		/* Current interpreter. */

 *	A standard Tcl completion code. If an error occurs then an error
 *	message is left in iPtr->result.
 *
 * Side effects:
 *	The variable given by myName is linked to the variable in framePtr
 *	given by otherP1 and otherP2, so that references to myName are
 *	redirected to the other variable like a symbolic link.
 *	Callers must Incr myNamePtr if they plan to Decr it.
 *	Callers must Incr otherP1Ptr if they plan to Decr it.
 *
 *----------------------------------------------------------------------
 */

static int
ObjMakeUpvar(
    Tcl_Interp *interp,		/* Interpreter containing variables. Used for

    const char *myName,		/* Name of variable which will refer to
				 * otherP1/otherP2. Must be a scalar. */
    int myFlags,		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
				 * indicates scope of myName. */
    int index)			/* If the variable to be linked is an indexed
				 * scalar, this is its index. Otherwise, -1 */
{
    Tcl_Obj *myNamePtr = NULL;
    int result;

    if (myName) {
	myNamePtr = Tcl_NewStringObj(myName, -1);
	Tcl_IncrRefCount(myNamePtr);


    }
    result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
    if (myNamePtr) {
	Tcl_DecrRefCount(myNamePtr);
    }
    return result;
}

/* Callers must Incr myNamePtr if they plan to Decr it. */
 
int
TclPtrObjMakeUpvar(
    Tcl_Interp *interp,		/* Interpreter containing variables. Used for
				 * error messages, too. */
    Var *otherPtr,		/* Pointer to the variable being linked-to. */
    Tcl_Obj *myNamePtr,		/* Name of variable which will refer to
				 * otherP1/otherP2. Must be a scalar. */

    } else if (nsPtr == (Namespace *) TclGetCurrentNamespace(interp)) {
	flags = TCL_NAMESPACE_ONLY;
    }

    for (varPtr = VarHashFirstVar(tablePtr, &search);  varPtr != NULL;
	    varPtr = VarHashFirstVar(tablePtr, &search)) {
	Tcl_Obj *objPtr = Tcl_NewObj();


	VarHashRefCount(varPtr)++;	/* Make sure we get to remove from
					 * hash. */
	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
	UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr,
		NULL, flags);
	Tcl_DecrRefCount(objPtr); /* free no longer needed obj */

    Tcl_Interp *interp,		/* Interpreter in which to record message. */
    const char *part1,
    const char *part2,		/* Variable's two-part name. */
    const char *operation,	/* String describing operation that failed,
				 * e.g. "read", "set", or "unset". */
    const char *reason)		/* String describing why operation failed. */
{
    Tcl_Obj *part2Ptr = NULL, *part1Ptr = Tcl_NewStringObj(part1, -1);



    if (part2) {
	part2Ptr = Tcl_NewStringObj(part2, -1);



    }

    TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1);

    Tcl_DecrRefCount(part1Ptr);
    if (part2Ptr) {
	Tcl_DecrRefCount(part2Ptr);

				 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
				 * and TCL_NAMESPACE_ONLY are given,
				 * TCL_GLOBAL_ONLY is ignored. */
{
    Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1);
    Tcl_Var var;


    var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags);
    Tcl_DecrRefCount(namePtr);
    return var;
}

static Tcl_Var
ObjFindNamespaceVar(

     * to check both possible search paths: from the specified namespace
     * context and from the global namespace.
     */

    varPtr = NULL;
    if (simpleName != name) {
	simpleNamePtr = Tcl_NewStringObj(simpleName, -1);

    } else {
	simpleNamePtr = namePtr;
    }

    for (search = 0;  (search < 2) && (varPtr == NULL);  search++) {
	if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
	    varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr);