tclvar.c

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

/* 
 * tclVar.c --
 *
 *	This file contains routines that implement Tcl variables
 *	(both scalars and arrays).
 *
 *	The implementation of arrays is modelled after an initial
 *	implementation by Mark Diekhans and Karl Lehenbauer.
 *
 * Copyright (c) 1987-1994 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 * Copyright (c) 2001 by Kevin B. Kenny.  All rights reserved.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclVar.c,v 1.69 2002/11/12 02:23:03 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * The strings below are used to indicate what went wrong when a
 * variable access is denied.
 */

static CONST char *noSuchVar =		"no such variable";
static CONST char *isArray =		"variable is array";
static CONST char *needArray =		"variable isn't array";
static CONST char *noSuchElement =	"no such element in array";
static CONST char *danglingElement =
				"upvar refers to element in deleted array";
static CONST char *danglingVar =	
				"upvar refers to variable in deleted namespace";
static CONST char *badNamespace =	"parent namespace doesn't exist";
static CONST char *missingName =	"missing variable name";
static CONST char *isArrayElement =	"name refers to an element in an array";

/*
 * Forward references to procedures defined later in this file:
 */

static int		CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
			    Var *varPtr, CONST char *part1, CONST char *part2,
			    int flags, CONST int leaveErrMsg));
static void		CleanupVar _ANSI_ARGS_((Var *varPtr,
			    Var *arrayPtr));
static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr,
			    CONST char *arrayName, Var *varPtr, int flags));
static void		DisposeTraceResult _ANSI_ARGS_((int flags,
			    char *result));
static int              ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, 
                            CallFrame *framePtr, Tcl_Obj *otherP1Ptr, 
                            CONST char *otherP2, CONST int otherFlags,
		            CONST char *myName, CONST int myFlags, int index));
static Var *		NewVar _ANSI_ARGS_((void));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST Var *varPtr, CONST char *varName,
			    Tcl_Obj *handleObj));
static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
			    CONST char *part1, CONST char *part2,
			    CONST char *operation, CONST char *reason));
static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
			    Tcl_Obj *objPtr));


/*
 * Functions defined in this file that may be exported in the future
 * for use by the bytecode compiler and engine or to the public interface.
 */

Var *		TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
		    CONST char *varName, int flags, CONST int create,
		    CONST char **errMsgPtr, int *indexPtr));
int		TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
		    Tcl_Obj *part1Ptr, CONST char *part2, int flags));

static Tcl_FreeInternalRepProc FreeLocalVarName;
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_UpdateStringProc UpdateLocalVarName;
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;

/*
 * Types of Tcl_Objs used to cache variable lookups.
 *
 * 
 * localVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the corresponding Proc 
 *   twoPtrValue.ptr2 = index into locals table
 *
 * nsVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1: pointer to the namespace containing the 
 *                     reference
 *   twoPtrValue.ptr2: pointer to the corresponding Var 
 *
 * parsedVarName - INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, 
 *                      or NULL if it is a scalar variable
 *   twoPtrValue.ptr2 = pointer to the element name string
 *                      (owned by this Tcl_Obj), or NULL if 
 *                      it is a scalar variable
 */

Tcl_ObjType tclLocalVarNameType = {
    "localVarName",
    FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
};

Tcl_ObjType tclNsVarNameType = {
    "namespaceVarName",
    FreeNsVarName, DupNsVarName, NULL, NULL
};

Tcl_ObjType tclParsedVarNameType = {
    "parsedVarName",
    FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
};

/*
 * Type of Tcl_Objs used to speed up array searches.
 *
 * INTERNALREP DEFINITION:
 *   twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
 *   twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
 *
 * Note that the value stored in ptr2 is the offset into the string of
 * the start of the variable name and not the address of the variable
 * name itself, as this can be safely copied.
 */
Tcl_ObjType tclArraySearchType = {
    "array search",
    NULL, NULL, NULL, SetArraySearchObj
};


/*
 *----------------------------------------------------------------------
 *
 * TclLookupVar --
 *
 *	This procedure is used to locate a variable given its name(s). It
 *      has been mostly superseded by TclObjLookupVar, it is now only used 
 *      by the string-based interfaces. It is kept in tcl8.4 mainly because 
 *      it is in the internal stubs table, so that some extension may be 
 *      calling it. 
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1 and part2, or NULL if the variable couldn't be found. If the
 *	variable is found, *arrayPtrPtr is filled in with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	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:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *
 *----------------------------------------------------------------------
 */
Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    CONST char *part1;	        /* If part2 isn't NULL, this is the name of
				 * an array. Otherwise, this
				 * is a full variable name that could
				 * include a parenthesized array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;			/* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    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. */
    int createPart1;		/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    int createPart2;		/* If 1, create hash table entry for part 2
				 * of 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;
    CONST char *elName;		/* Name of array element or NULL; may be
				 * same as part2, or may be openParen+1. */
    int openParen, closeParen;
                                /* If this procedure parses a name into
				 * array and index, these are the offsets to 
				 * the parens around the index.  Otherwise 
				 * they are -1. */
    register CONST char *p;
    CONST char *errMsg = NULL;
    int index;
#define VAR_NAME_BUF_SIZE 26
    char buffer[VAR_NAME_BUF_SIZE];
    char *newVarName = buffer;

    varPtr = NULL;
    *arrayPtrPtr = NULL;
    openParen = closeParen = -1;

    /*
     * Parse part1 into array name and index.
     * Always check if part1 is an array element name and allow it only if
     * part2 is not given.   
     * (if one does not care about creating array elements that can't be used
     *  from tcl, and prefer slightly better performance, one can put
     *  the following in an   if (part2 == NULL) { ... } block and remove
     *  the part2's test and error reporting  or move that code in array set)
     */

    elName = part2;
    for (p = part1; *p ; p++) {
	if (*p == '(') {
	    openParen = p - part1;
	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p == ')') {
		if (part2 != NULL) {
		    if (flags & TCL_LEAVE_ERR_MSG) {
			VarErrMsg(interp, part1, part2, msg, needArray);
		    }
		    return NULL;
		}
		closeParen = p - part1;
	    } else {
		openParen = -1;
	    }
	    break;
	}
    }
    if (openParen != -1) {
	if (closeParen >= VAR_NAME_BUF_SIZE) {
	    newVarName = ckalloc((unsigned int) (closeParen+1));
	}
	memcpy(newVarName, part1, (unsigned int) closeParen);
	newVarName[openParen] = '\0';
	newVarName[closeParen] = '\0';
	part1 = newVarName;
	elName = newVarName + openParen + 1;
    }

    varPtr = TclLookupSimpleVar(interp, part1, flags, 
            createPart1, &errMsg, &index);
    if (varPtr == NULL) {
	if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
	    VarErrMsg(interp, part1, elName, msg, errMsg);
	}
    } else {
	while (TclIsVarLink(varPtr)) {
	    varPtr = varPtr->value.linkPtr;
	}
	if (elName != NULL) {
	    *arrayPtrPtr = varPtr;
	    varPtr = TclLookupArrayElement(interp, part1, elName, flags, 
		    msg, createPart1, createPart2, varPtr);
	}
    }
    if (newVarName != buffer) {
	ckfree(newVarName);
    }

    return varPtr;
	
#undef VAR_NAME_BUF_SIZE
}

/*
 *----------------------------------------------------------------------
 *
 * TclObjLookupVar --
 *
 *	This procedure is used by virtually all of the variable code to
 *	locate a variable given its name(s). The parsing into array/element
 *      components and (if possible) the lookup results are cached in 
 *      part1Ptr, which is converted to one of the varNameTypes.
 *
 * Results:
 *	The return value is a pointer to the variable structure indicated by
 *	part1Ptr and part2, or NULL if the variable couldn't be found. If 
 *      the variable is found, *arrayPtrPtr is filled with the address of the
 *	variable structure for the array that contains the variable (or NULL
 *	if the variable is a scalar). If the variable can't be found and
 *	either createPart1 or createPart2 are 1, a new as-yet-undefined
 *	(VAR_UNDEFINED) variable structure is created, entered into a hash
 *	table, and returned.
 *
 *	If the variable isn't found and creation wasn't specified, or some
 *	other error occurs, NULL is returned and an error message is left in
 *	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:
 *	New hashtable entries may be created if createPart1 or createPart2
 *	are 1.
 *      The object part1Ptr is converted to one of tclLocalVarNameType, 
 *      tclNsVarNameType or tclParsedVarNameType and caches as much of the
 *      lookup as it can.
 *
 *----------------------------------------------------------------------
 */
Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
        arrayPtrPtr)
    Tcl_Interp *interp;		/* Interpreter to use for lookup. */
    register Tcl_Obj *part1Ptr;	/* If part2 isn't NULL, this is the name 
				 * of an array. Otherwise, this is a full 
				 * variable name that could include a parenthesized 
				 * array element. */
    CONST char *part2;		/* Name of element within array, or NULL. */
    int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
				 * and TCL_LEAVE_ERR_MSG bits matter. */
    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 createPart1;	/* If 1, create hash table entry for part 1
				 * of name, if it doesn't already exist. If
				 * 0, return error if it doesn't exist. */
    CONST int createPart2;	/* If 1, create hash table entry for part 2
				 * of 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. */
{
    Interp *iPtr = (Interp *) interp;
    register Var *varPtr;	/* Points to the variable's in-frame Var
				 * structure. */
    char *part1;
    int index, len1, len2;
    int parsed = 0;
    Tcl_Obj *objPtr;
    Tcl_ObjType *typePtr = part1Ptr->typePtr;
    CONST char *errMsg = NULL;
    CallFrame *varFramePtr = iPtr->varFramePtr;
    Namespace *nsPtr;

    /*
     * If part1Ptr is a tclParsedVarNameType, separate it into the 
     * pre-parsed parts.
     */

    *arrayPtrPtr = NULL;
    if (typePtr == &tclParsedVarNameType) {
	if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
	    if (part2 != NULL) {
		/*
		 * ERROR: part1Ptr is already an array element, cannot 
		 * specify a part2.
		 */