tclvar.c

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

		if (flags & TCL_LEAVE_ERR_MSG) {
		    part1 = TclGetString(part1Ptr);
		    VarErrMsg(interp, part1, part2, msg, needArray);
		}
		return NULL;
	    }
	    part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
	    part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
	    typePtr = part1Ptr->typePtr;
	}
	parsed = 1;
    }
    part1 = Tcl_GetStringFromObj(part1Ptr, &len1);    

    nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
    if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
	goto doParse;
    }
    
    if (typePtr == &tclLocalVarNameType) {
	Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
	int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
	int useLocal;

	useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
	        && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
	if (useLocal && (procPtr == varFramePtr->procPtr)) {
	    /*
	     * part1Ptr points to an indexed local variable of the
	     * correct procedure: use the cached value.
	     */
	    
	    varPtr = &(varFramePtr->compiledLocals[localIndex]);
	    goto donePart1;
	}
	goto doneParsing;
    } else if (typePtr == &tclNsVarNameType) {
	Namespace *cachedNsPtr;
	int useGlobal, useReference;

	varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
	cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
	useGlobal = (cachedNsPtr == iPtr->globalNsPtr) 
	    && ((flags & TCL_GLOBAL_ONLY) 
		|| ((*part1 == ':') && (*(part1+1) == ':'))
		|| (varFramePtr == NULL) 
		|| (!varFramePtr->isProcCallFrame 
		    && (nsPtr == iPtr->globalNsPtr)));
	useReference = useGlobal || ((cachedNsPtr == nsPtr) 
	        && ((flags & TCL_NAMESPACE_ONLY) 
		    || (varFramePtr && !varFramePtr->isProcCallFrame 
			&& !(flags & TCL_GLOBAL_ONLY)
			/* careful: an undefined ns variable could
			 * be hiding a valid global reference. */
			&& !(varPtr->flags & VAR_UNDEFINED))));
	if (useReference && (varPtr->hPtr != NULL)) {
	    /*
	     * A straight global or namespace reference, use it. It isn't 
	     * so simple to deal with 'implicit' namespace references, i.e., 
	     * those where the reference could be to either a namespace 
	     * or a global variable. Those we lookup again.
	     *
	     * If (varPtr->hPtr == NULL), this might be a reference to a
	     * variable in a deleted namespace, kept alive by e.g. part1Ptr.
	     * We could conceivably be so unlucky that a new namespace was
	     * created at the same address as the deleted one, so to be 
	     * safe we test for a valid hPtr.
	     */
	    goto donePart1;
	}
	goto doneParsing;
    }

    doParse:
    if (!parsed && (*(part1 + len1 - 1) == ')')) {
	/*
	 * part1Ptr is possibly an unparsed array element.
	 */
	register int i;
	char *newPart2;
	len2 = -1;
	for (i = 0; i < len1; i++) {
	    if (*(part1 + i) == '(') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, part2, msg, needArray);
		    }
		}			

		/*
		 * part1Ptr points to an array element; first copy 
		 * the element name to a new string part2.
		 */

		part2 = part1 + i + 1;
		len2 = len1 - i - 2;
		len1 = i;

		newPart2 = ckalloc((unsigned int) (len2+1));
		memcpy(newPart2, part2, (unsigned int) len2);
		*(newPart2+len2) = '\0';
		part2 = newPart2;

		/*
		 * Free the internal rep of the original part1Ptr, now
		 * renamed objPtr, and set it to tclParsedVarNameType.
		 */

		objPtr = part1Ptr;
		if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
		    typePtr->freeIntRepProc(objPtr);
		}
		objPtr->typePtr = &tclParsedVarNameType;

		/*
		 * Define a new string object to hold the new part1Ptr, i.e., 
		 * the array name. Set the internal rep of objPtr, reset
		 * typePtr and part1 to contain the references to the
		 * array name.
		 */

		part1Ptr = Tcl_NewStringObj(part1, len1);
		Tcl_IncrRefCount(part1Ptr);

		objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
		objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;		

		typePtr = part1Ptr->typePtr;
		part1 = TclGetString(part1Ptr);
		break;
	    }
	}
    }
    
    doneParsing:
    /*
     * part1Ptr is not an array element; look it up, and convert 
     * it to one of the cached types if possible.
     */

    if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
	typePtr->freeIntRepProc(part1Ptr);
	part1Ptr->typePtr = NULL;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    VarErrMsg(interp, part1, part2, msg, errMsg);
	}
	return NULL;
    }

    /*
     * Cache the newly found variable if possible.
     */

    if (index >= 0) {
        /*
	 * An indexed local variable.
	 */

	Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;

	part1Ptr->typePtr = &tclLocalVarNameType;
	procPtr->refCount++;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
    } else if (index > -3) {
	Namespace *nsPtr;
    
	nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
	varPtr->refCount++;
	part1Ptr->typePtr = &tclNsVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
	part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
    } else {
	/*
	 * At least mark part1Ptr as already parsed.
	 */
	part1Ptr->typePtr = &tclParsedVarNameType;
	part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
	part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
    }
    
    donePart1:
#if 0
    if (varPtr == NULL) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    part1 = TclGetString(part1Ptr);
	    VarErrMsg(interp, part1, part2, msg, 
		    "Cached variable reference is NULL.");
	}
	return NULL;
    }
#endif
    while (TclIsVarLink(varPtr)) {
	varPtr = varPtr->value.linkPtr;
    }

    if (part2 != NULL) {
	/*
	 * Array element sought: look it up.
	 */

	part1 = TclGetString(part1Ptr);
	*arrayPtrPtr = varPtr;
	varPtr = TclLookupArrayElement(interp, part1, part2, 
                flags, msg, createPart1, createPart2, varPtr);
    }
    return varPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * TclLookupSimpleVar --
 *
 *	This procedure is used by to locate a simple variable (i.e., not
 *      an array element) given its name.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	varName, or NULL if the variable couldn't be found. If the variable 
 *      can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) 
 *      variable structure is created, entered into a hash table, and returned.
 *
 *      If the current CallFrame corresponds to a proc and the variable found is
 *      one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
 *      *indexPtr will be set to (according to the needs of TclObjLookupVar):
 *               -1 a global reference
 *               -2 a reference to a namespace variable
 *               -3 a non-cachable reference, i.e., one of:
 *                    . non-indexed local var
 *                    . a reference of unknown origin;
 *                    . resolution by a namespace or interp resolver
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and the corresponding error
 *	message is left in *errMsgPtr. 
 *
 *	Note: it's possible for the variable returned to be VAR_UNDEFINED
 *	even 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.
 *
 *----------------------------------------------------------------------
 */

Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *varName;        /* This is a simple variable name that could
				 * representa scalar or an array. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    CONST int create;		/* If 1, create hash table entry for varname,
				 * if it doesn't already exist. If 0, return 
				 * error if it doesn't exist. */
    CONST char **errMsgPtr;
    int *indexPtr;
{    
    Interp *iPtr = (Interp *) interp;
    CallFrame *varFramePtr = iPtr->varFramePtr;
				/* Points to the procedure call frame whose
				 * variables are currently in use. Same as
				 * the current procedure's frame, if any,
				 * unless an "uplevel" is executing. */
    Tcl_HashTable *tablePtr;	/* Points to the hashtable, if any, in which
				 * to look up the variable. */
    Tcl_Var var;                /* Used to search for global names. */
    Var *varPtr;		/* Points to the Var structure returned for
				 * the variable. */
    Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
    ResolverScheme *resPtr;
    Tcl_HashEntry *hPtr;
    int new, i, result;

    varPtr = NULL;
    varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */
    *indexPtr = -3;

    /*
     * If this namespace has a variable resolver, then give it first
     * crack at the variable resolution.  It may return a Tcl_Var
     * value, it may signal to continue onward, or it may signal
     * an error.
     */
    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
        cxtNsPtr = iPtr->globalNsPtr;
    } else {
        cxtNsPtr = iPtr->varFramePtr->nsPtr;
    }

    if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
        resPtr = iPtr->resolverPtr;

        if (cxtNsPtr->varResProc) {
            result = (*cxtNsPtr->varResProc)(interp, varName,
		    (Tcl_Namespace *) cxtNsPtr, flags, &var);
        } else {
            result = TCL_CONTINUE;
        }

        while (result == TCL_CONTINUE && resPtr) {
            if (resPtr->varResProc) {
                result = (*resPtr->varResProc)(interp, varName,
			(Tcl_Namespace *) cxtNsPtr, flags, &var);
            }
            resPtr = resPtr->nextPtr;
        }

        if (result == TCL_OK) {
            varPtr = (Var *) var;
	    return varPtr;
        } else if (result != TCL_CONTINUE) {
	    return NULL;
        }
    }

    /*
     * Look up varName. Look it up as either a namespace variable or as a
     * local variable in a procedure call frame (varFramePtr).
     * Interpret varName as a namespace variable if:
     *    1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
     *    2) there is no active frame (we're at the global :: scope),
     *    3) the active frame was pushed to define the namespace context
     *       for a "namespace eval" or "namespace inscope" command,
     *    4) the name has namespace qualifiers ("::"s).
     * Otherwise, if varName is a local variable, search first in the
     * frame's array of compiler-allocated local variables, then in its
     * hashtable for runtime-created local variables.
     *
     * If create and the variable isn't found, create the variable and,
     * if necessary, create varFramePtr's local var hashtable.
     */

    if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
	    || (varFramePtr == NULL)
	    || !varFramePtr->isProcCallFrame
	    || (strstr(varName, "::") != NULL)) {
	CONST char *tail;
	int lookGlobal;
	
	lookGlobal = (flags & TCL_GLOBAL_ONLY) 
	    || (cxtNsPtr == iPtr->globalNsPtr)
	    || ((*varName == ':') && (*(varName+1) == ':'));
	if (lookGlobal) {
	    *indexPtr = -1;
	    flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
	} else if (flags & TCL_NAMESPACE_ONLY) {
	    *indexPtr = -2;
	}

	/*
	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
	 * or otherwise generate our own error!
	 */
	var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
		flags & ~TCL_LEAVE_ERR_MSG);
	if (var != (Tcl_Var) NULL) {
            varPtr = (Var *) var;
        }
	if (varPtr == NULL) {
	    if (create) {   /* var wasn't found so create it  */
		TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
			flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
		if (varNsPtr == NULL) {
		    *errMsgPtr = badNamespace;
		    return NULL;
		}
		if (tail == NULL) {
		    *errMsgPtr = missingName;
		    return NULL;
		}