tclvar.c

来自「tcl是工具命令语言」· C语言 代码 · 共 1,908 行 · 第 1/5 页

		hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = varNsPtr;
		if ((lookGlobal)  || (varNsPtr == NULL)) {
		    /*
		     * The variable was created starting from the global
		     * namespace: a global reference is returned even if 
		     * it wasn't explicitly requested.
		     */
		    *indexPtr = -1;
		} else {
		    *indexPtr = -2;
		}
	    } else {		/* var wasn't found and not to create it */
		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	}
    } else {			/* local var: look in frame varFramePtr */
	Proc *procPtr = varFramePtr->procPtr;
	int localCt = procPtr->numCompiledLocals;
	CompiledLocal *localPtr = procPtr->firstLocalPtr;
	Var *localVarPtr = varFramePtr->compiledLocals;
	int varNameLen = strlen(varName);
	
	for (i = 0;  i < localCt;  i++) {
	    if (!TclIsVarTemporary(localPtr)) {
		register char *localName = localVarPtr->name;
		if ((varName[0] == localName[0])
		        && (varNameLen == localPtr->nameLength)
		        && (strcmp(varName, localName) == 0)) {
		    *indexPtr = i;
		    return localVarPtr;
		}
	    }
	    localVarPtr++;
	    localPtr = localPtr->nextPtr;
	}
	tablePtr = varFramePtr->varTablePtr;
	if (create) {
	    if (tablePtr == NULL) {
		tablePtr = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
		varFramePtr->varTablePtr = tablePtr;
	    }
	    hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
	    if (new) {
		varPtr = NewVar();
		Tcl_SetHashValue(hPtr, varPtr);
		varPtr->hPtr = hPtr;
		varPtr->nsPtr = NULL; /* a local variable */
	    } else {
		varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    }
	} else {
	    hPtr = NULL;
	    if (tablePtr != NULL) {
		hPtr = Tcl_FindHashEntry(tablePtr, varName);
	    }
	    if (hPtr == NULL) {
		*errMsgPtr = noSuchVar;
		return NULL;
	    }
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	}
    }
    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupArrayElement --
 *
 *	This procedure is used to locate a variable which is in an array's 
 *      hashtable given a pointer to the array's Var structure and the 
 *      element's name.
 *
 * Results:
 *	The return value is a pointer to the variable structure , or NULL if 
 *      the variable couldn't be found. 
 *
 *      If arrayPtr points to a variable that isn't an array and createPart1 
 *      is 1, the corresponding variable will be converted to an array. 
 *      Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *      If the variable is not found and createPart2 is 1, the variable is
 *      created. Otherwise, NULL is returned and an error message is left in
 *	the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even if createPart1 or createPart2 are 1 (these only cause the hash
 *	table entry or array 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:
 *      The variable at arrayPtr may be converted to be an array if 
 *      createPart1 is 1. A new hashtable entry may be created if createPart2 
 *      is 1.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *arrayName;	        /* This is the name of the array. */
    CONST char *elName;		/* Name of element within array. */
    CONST int flags;		/* Only TCL_LEAVE_ERR_MSG bit matters. */
    CONST char *msg;			/* Verb to use in error messages, e.g.
				 * "read" or "set". Only needed if
				 * TCL_LEAVE_ERR_MSG is set in flags. */
    CONST int createArray;	/* If 1, transform arrayName to be an array
				 * if it isn't one yet and the transformation 
				 * is possible. If 0, return error if it 
				 * isn't already an array. */
    CONST int createElem;	/* If 1, create hash table entry for the 
				 * element, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    Var *arrayPtr;	        /* Pointer to the array's Var structure. */
{
    Tcl_HashEntry *hPtr;
    int new;
    Var *varPtr;

    /*
     * We're dealing with an array element. Make sure the variable is an
     * array and look up the element (create the element if desired).
     */

    if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
	if (!createArray) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
	    }
	    return NULL;
	}

	/*
	 * Make sure we are not resurrecting a namespace variable from a
	 * deleted namespace!
	 */
	if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, danglingVar);
	    }
	    return NULL;
	}

	TclSetVarArray(arrayPtr);
	TclClearVarUndefined(arrayPtr);
	arrayPtr->value.tablePtr =
	    (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
	Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
    } else if (!TclIsVarArray(arrayPtr)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, arrayName, elName, msg, needArray);
	}
	return NULL;
    }

    if (createElem) {
	hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
	if (new) {
	    if (arrayPtr->searchPtr != NULL) {
		DeleteSearches(arrayPtr);
	    }
	    varPtr = NewVar();
	    Tcl_SetHashValue(hPtr, varPtr);
	    varPtr->hPtr = hPtr;
	    varPtr->nsPtr = arrayPtr->nsPtr;
	    TclSetVarArrayElement(varPtr);
	}
    } else {
	hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
	if (hPtr == NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
	    }
	    return NULL;
	}
    }
    return (Var *) Tcl_GetHashValue(hPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar --
 *
 *	Return the value of a Tcl variable as a string.
 *
 * Results:
 *	The return value points to the current value of varName as a string.
 *	If the variable is not defined or can't be read because of a clash
 *	in array usage then a NULL pointer is returned and an error message
 *	is left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
 *	Note: the return value is only valid up until the next change to the
 *	variable; if you depend on the value lasting longer than that, then
 *	make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    CONST char *varName;	/* Name of a variable in interp. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY,
				 * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
				 * bits. */
{
    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2 --
 *
 *	Return the value of a Tcl variable as a string, given a two-part
 *	name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current value of the variable given
 *	by part1 and part2 as a string. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interp's result if the
 *	TCL_LEAVE_ERR_MSG flag is set. Note: the return value is only valid
 *	up until the next change to the variable; if you depend on the value
 *	lasting longer than that, then make yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    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,
				 * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
                                 * bits. */
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
    if (objPtr == NULL) {
	return NULL;
    }
    return TclGetString(objPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2Ex --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    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. */
{
    Var *varPtr, *arrayPtr;

    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */
    varPtr = TclLookupVar(interp, part1, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ObjGetVar2 --
 *
 *	Return the value of a Tcl variable as a Tcl object, given a
 *	two-part name consisting of array name and element within array.
 *
 * Results:
 *	The return value points to the current object value of the variable
 *	given by part1Ptr and part2Ptr. If the specified variable doesn't
 *	exist, or if there is a clash in array usage, then NULL is returned
 *	and a message will be left in the interpreter's result if the
 *	TCL_LEAVE_ERR_MSG flag is set.
 *
 * Side effects:
 *	The ref count for the returned object is _not_ incremented to
 *	reflect the returned reference; if you want to keep a reference to
 *	the object you must increment its ref count yourself.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    register Tcl_Obj *part1Ptr;	/* Points to an object holding the name of
				 * an array (if part2 is non-NULL) or the
				 * name of a variable. */
    register Tcl_Obj *part2Ptr;	/* If non-null, points to an object holding
				 * the name of an element in the array
				 * part1Ptr. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY and
				 * TCL_LEAVE_ERR_MSG bits. */
{
    Var *varPtr, *arrayPtr;
    char *part1, *part2;

    part1 = Tcl_GetString(part1Ptr);
    part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
    
    /*
     * We need a special flag check to see if we want to create part 1,
     * because commands like lappend require read traces to trigger for
     * previously non-existent values.
     */
    varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
            /*createPart1*/ (flags & TCL_TRACE_READS),
	    /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return NULL;
    }

    return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPtrGetVar --
 *