tclvar.c

CMX990 demonstration board (DE9901)

/* 
 * 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 Karl Lehenbauer, Mark Diekhans and
 *	Peter da Silva.
 *
 * Copyright 1987-1991 Regents of the University of California
 * Permission to use, copy, modify, and distribute this
 * software and its documentation for any purpose and without
 * fee is hereby granted, provided that the above copyright
 * notice appear in all copies.  The University of California
 * makes no representations about the suitability of this
 * software for any purpose.  It is provided "as is" without
 * express or implied warranty.
 *
 * $Id: tclVar.c,v 1.1.1.1 2001/04/29 20:35:17 karll Exp $
 */

#include "tclInt.h"

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

static char *noSuchVar =	"no such variable";
static char *isArray =		"variable is array";
static char *needArray =	"variable isn't array";
static char *noSuchElement =	"no such element in array";
static char *traceActive =	"trace is active on variable";

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

static  char *		CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
			    Tcl_HashEntry *hPtr, char *part1, char *part2,
			    int flags));
static void		DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
static void		DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
			    Var *varPtr, int flags));
static Var *		NewVar _ANSI_ARGS_((int space));
static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
			    Var *varPtr, char *varName, char *string));
static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
			    char *part1, char *part2, char *operation,
			    char *reason));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar --
 *
 *	Return the value of a Tcl variable.
 *
 * Results:
 *	The return value points to the current value of varName.  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 interp->result if the TCL_LEAVE_ERR_MSG
 *	flag is set.  Note:  the return value is only valid up until
 *	the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
 *	the value lasting longer than that, then make yourself a private
 *	copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    char *varName;		/* Name of a variable in interp. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY
				 * or TCL_LEAVE_ERR_MSG bits. */
{
    register char *p;

    /*
     * If varName refers to an array (it ends with a parenthesized
     * element name), then handle it specially.
     */

    for (p = varName; *p != '\0'; p++) {
	if (*p == '(') {
	    char *result;
	    char *open = p;

	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p != ')') {
		goto scalar;
	    }
	    *open = '\0';
	    *p = '\0';
	    result = Tcl_GetVar2(interp, varName, open+1, flags);
	    *open = '(';
	    *p = ')';
	    return result;
	}
    }

    scalar:
    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetVar2 --
 *
 *	Return the value of a Tcl variable, 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.  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 interp->result if the
 *	TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
 *	only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
 *	if you depend on the value lasting longer than that, then make
 *	yourself a private copy.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_GetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    char *part1;		/* Name of array (if part2 is NULL) or
				 * name of variable. */
    char *part2;		/* If non-null, gives name of element in
				 * array. */
    int flags;			/* OR-ed combination of TCL_GLOBAL_ONLY
				 * or TCL_LEAVE_ERR_MSG bits. */
{
    Tcl_HashEntry *hPtr;
    Var *varPtr;
    Interp *iPtr = (Interp *) interp;
    Var *arrayPtr = NULL;

    /*
     * Lookup the first name.
     */

    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
	hPtr = Tcl_FindHashEntry(&iPtr->globalTable, part1);
    } else {
	hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, part1);
    }
    if (hPtr == NULL) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "read", noSuchVar);
	}
	return NULL;
    }
    varPtr = (Var *) Tcl_GetHashValue(hPtr);
    if (varPtr->flags & VAR_UPVAR) {
	hPtr = varPtr->value.upvarPtr;
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }

    /*
     * If this is an array reference, then remember the traces on the array
     * and lookup the element within the array.
     */

    if (part2 != NULL) {
	if (varPtr->flags & VAR_UNDEFINED) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, part2, "read", noSuchVar);
	    }
	    return NULL;
	} else if (!(varPtr->flags & VAR_ARRAY)) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, part2, "read", needArray);
	    }
	    return NULL;
	}
	arrayPtr = varPtr;
	hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
	if (hPtr == NULL) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, part2, "read", noSuchElement);
	    }
	    return NULL;
	}
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }

    /*
     * Invoke any traces that have been set for the variable.
     */

    if ((varPtr->tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	char *msg;

	msg = CallTraces(iPtr, arrayPtr, hPtr, part1, part2,
		(flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
	if (msg != NULL) {
	    VarErrMsg(interp, part1, part2, "read", msg);
	    return NULL;
	}

	/*
	 * Watch out!  The variable could have gotten re-allocated to
	 * a larger size.  Fortunately the hash table entry will still
	 * be around.
	 */

	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }
    if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "read", noSuchVar);
	}
	return NULL;
    }
    return varPtr->value.string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar --
 *
 *	Change the value of a variable.
 *
 * Results:
 *	Returns a pointer to the malloc'ed string holding the new
 *	value of the variable.  The caller should not modify this
 *	string.  If the write operation was disallowed then NULL
 *	is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
 *	an explanatory message will be left in interp->result.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp,
 *	its value is changed to newValue.  If varName isn't currently
 *	defined, then a new global variable by that name is created.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_SetVar(interp, varName, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    char *varName;		/* Name of a variable in interp. */
    char *newValue;		/* New value for varName. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
				 * TCL_LEAVE_ERR_MSG. */
{
    register char *p;

    /*
     * If varName refers to an array (it ends with a parenthesized
     * element name), then handle it specially.
     */

    for (p = varName; *p != '\0'; p++) {
	if (*p == '(') {
	    char *result;
	    char *open = p;

	    do {
		p++;
	    } while (*p != '\0');
	    p--;
	    if (*p != ')') {
		goto scalar;
	    }
	    *open = '\0';
	    *p = '\0';
	    result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
	    *open = '(';
	    *p = ')';
	    return result;
	}
    }

    scalar:
    return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetVar2 --
 *
 *	Given a two-part variable name, which may refer either to a
 *	scalar variable or an element of an array, change the value
 *	of the variable.  If the named scalar or array or element
 *	doesn't exist then create one.
 *
 * Results:
 *	Returns a pointer to the malloc'ed string holding the new
 *	value of the variable.  The caller should not modify this
 *	string.  If the write operation was disallowed because an
 *	array was expected but not found (or vice versa), then NULL
 *	is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
 *	an explanatory message will be left in interp->result.
 *
 * Side effects:
 *	The value of the given variable is set.  If either the array
 *	or the entry didn't exist then a new one is created.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
    Tcl_Interp *interp;		/* Command interpreter in which variable is
				 * to be looked up. */
    char *part1;		/* If part2 is NULL, this is name of scalar
				 * variable.  Otherwise it is name of array. */
    char *part2;		/* Name of an element within array, or NULL. */
    char *newValue;		/* New value for variable. */
    int flags;			/* Various flags that tell how to set value:
				 * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
				 * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
				 * TCL_LEAVE_ERR_MSG . */
{
    Tcl_HashEntry *hPtr;
    register Var *varPtr = NULL;
				/* Initial value only used to stop compiler
				 * from complaining; not really needed. */
    register Interp *iPtr = (Interp *) interp;
    int length, new, listFlags;
    Var *arrayPtr = NULL;

    /*
     * Lookup the first name.
     */

    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
	hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, part1, &new);
    } else {
	hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
		part1, &new);
    }
    if (!new) {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
	if (varPtr->flags & VAR_UPVAR) {
	    hPtr = varPtr->value.upvarPtr;
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	}
    }

    /*
     * If this is an array reference, then create a new array (if
     * needed), remember any traces on the array, and lookup the
     * element within the array.
     */

    if (part2 != NULL) {
	if (new) {
	    varPtr = NewVar(0);
	    Tcl_SetHashValue(hPtr, varPtr);
	    varPtr->flags = VAR_ARRAY;
	    varPtr->value.tablePtr = (Tcl_HashTable *)
		    ckalloc(sizeof(Tcl_HashTable));
	    Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
	} else {
	    if (varPtr->flags & VAR_UNDEFINED) {
		varPtr->flags = VAR_ARRAY;
		varPtr->value.tablePtr = (Tcl_HashTable *)
			ckalloc(sizeof(Tcl_HashTable));
		Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
	    } else if (!(varPtr->flags & VAR_ARRAY)) {
		if (flags & TCL_LEAVE_ERR_MSG) {
		    VarErrMsg(interp, part1, part2, "set", needArray);
		}
		return NULL;
	    }
	    arrayPtr = varPtr;
	}
	hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
    }

    /*
     * Compute how many bytes will be needed for newValue (leave space
     * for a separating space between list elements).
     */

    if (flags & TCL_LIST_ELEMENT) {
	length = Tcl_ScanElement(newValue, &listFlags) + 1;
    } else {
	length = strlen(newValue);
    }

    /*
     * If the variable doesn't exist then create a new one.  If it
     * does exist then clear its current value unless this is an
     * append operation.
     */

    if (new) {
	varPtr = NewVar(length);
	Tcl_SetHashValue(hPtr, varPtr);
	if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
	    DeleteSearches(arrayPtr);
	}
    } else {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
	if (varPtr->flags & VAR_ARRAY) {
	    if (flags & TCL_LEAVE_ERR_MSG) {
		VarErrMsg(interp, part1, part2, "set", isArray);
	    }
	    return NULL;
	}
	if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
	    varPtr->valueLength = 0;
	}
    }

    /*
     * Make sure there's enough space to hold the variable's
     * new value.  If not, enlarge the variable's space.
     */

    if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
	Var *newVarPtr;
	int newSize;

	newSize = 2*varPtr->valueSpace;
	if (newSize <= (length + varPtr->valueLength)) {
	    newSize += length;
	}
	newVarPtr = NewVar(newSize);
	newVarPtr->valueLength = varPtr->valueLength;
	newVarPtr->upvarUses = varPtr->upvarUses;
	newVarPtr->tracePtr = varPtr->tracePtr;
	newVarPtr->searchPtr = varPtr->searchPtr;