tclvar.c

CMX990 demonstration board (DE9901)

	newVarPtr->flags = varPtr->flags;
	strcpy(newVarPtr->value.string, varPtr->value.string);
	Tcl_SetHashValue(hPtr, newVarPtr);
	ckfree((char *) varPtr);
	varPtr = newVarPtr;
    }

    /*
     * Append the new value to the variable, either as a list
     * element or as a string.
     */

    if (flags & TCL_LIST_ELEMENT) {
	if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
	    varPtr->value.string[varPtr->valueLength] = ' ';
	    varPtr->valueLength++;
	}
	varPtr->valueLength += Tcl_ConvertElement(newValue,
		varPtr->value.string + varPtr->valueLength, listFlags);
	varPtr->value.string[varPtr->valueLength] = 0;
    } else {
	strcpy(varPtr->value.string + varPtr->valueLength, newValue);
	varPtr->valueLength += length;
    }
    varPtr->flags &= ~VAR_UNDEFINED;

    /*
     * Invoke any write traces 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_WRITES);
	if (msg != NULL) {
	    VarErrMsg(interp, part1, part2, "set", 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);
    }
    return varPtr->value.string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar --
 *
 *	Delete a variable, so that it may not be accessed anymore.
 *
 * Results:
 *	Returns 0 if the variable was successfully deleted, -1
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in interp->result.
 *
 * Side effects:
 *	If varName is defined as a local or global variable in interp,
 *	it is deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar(interp, varName, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    char *varName;		/* Name of a variable in interp.  May be
				 * either a scalar name or an array name
				 * or an element in an array. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
{
    register char *p;
    int result;

    /*
     * Figure out whether this is an array reference, then call
     * Tcl_UnsetVar2 to do all the real work.
     */

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

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

    scalar:
    return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UnsetVar2 --
 *
 *	Delete a variable, given a 2-part name.
 *
 * Results:
 *	Returns 0 if the variable was successfully deleted, -1
 *	if the variable can't be unset.  In the event of an error,
 *	if the TCL_LEAVE_ERR_MSG flag is set then an error message
 *	is left in interp->result.
 *
 * Side effects:
 *	If part1 and part2 indicate a local or global variable in interp,
 *	it is deleted.  If part1 is an array name and part2 is NULL, then
 *	the whole array is deleted.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_UnsetVar2(interp, part1, part2, flags)
    Tcl_Interp *interp;		/* Command interpreter in which varName is
				 * to be looked up. */
    char *part1;		/* Name of variable or array. */
    char *part2;		/* Name of element within array or NULL. */
    int flags;			/* OR-ed combination of any of
				 * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
{
    Tcl_HashEntry *hPtr, dummyEntry;
    Var *varPtr, dummyVar;
    Interp *iPtr = (Interp *) interp;
    Var *arrayPtr = NULL;

    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, "unset", noSuchVar);
	}
	return -1;
    }
    varPtr = (Var *) Tcl_GetHashValue(hPtr);

    /*
     * For global variables referenced in procedures, leave the procedure's
     * reference variable in place, but unset the global variable.  Can't
     * decrement the actual variable's use count, since we didn't delete
     * the reference variable.
     */

    if (varPtr->flags & VAR_UPVAR) {
	hPtr = varPtr->value.upvarPtr;
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }

    /*
     * If the variable being deleted is an element of an array, then
     * remember trace procedures on the overall array and find the
     * element to delete.
     */

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

    /*
     * If there is a trace active on this variable or if the variable
     * is already being deleted then don't delete the variable:  it
     * isn't safe, since there are procedures higher up on the stack
     * that will use pointers to the variable.  Also don't delete an
     * array if there are traces active on any of its elements.
     */

    if (varPtr->flags &
	    (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "unset", traceActive);
	}
	return -1;
    }

    /*
     * The code below is tricky, because of the possibility that
     * a trace procedure might try to access a variable being
     * deleted.  To handle this situation gracefully, copy the
     * contents of the variable and its hash table entry to
     * dummy variables, then clean up the actual variable so that
     * it's been completely deleted before the traces are called.
     * Then call the traces, and finally clean up the variable's
     * storage using the dummy copies.
     */

    dummyVar = *varPtr;
    Tcl_SetHashValue(&dummyEntry, &dummyVar);
    if (varPtr->upvarUses == 0) {
	Tcl_DeleteHashEntry(hPtr);
	ckfree((char *) varPtr);
    } else {
	varPtr->flags = VAR_UNDEFINED;
	varPtr->tracePtr = NULL;
    }

    /*
     * Call trace procedures for the variable being deleted and delete
     * its traces.
     */

    if ((dummyVar.tracePtr != NULL)
	    || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
	(void) CallTraces(iPtr, arrayPtr, &dummyEntry, part1, part2,
		(flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
	while (dummyVar.tracePtr != NULL) {
	    VarTrace *tracePtr = dummyVar.tracePtr;
	    dummyVar.tracePtr = tracePtr->nextPtr;
	    ckfree((char *) tracePtr);
	}
    }

    /*
     * If the variable is an array, delete all of its elements.  This
     * must be done after calling the traces on the array, above (that's
     * the way traces are defined).
     */

    if (dummyVar.flags & VAR_ARRAY) {
	DeleteArray(iPtr, part1, &dummyVar,
	    (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
    }
    if (dummyVar.flags & VAR_UNDEFINED) {
	if (flags & TCL_LEAVE_ERR_MSG) {
	    VarErrMsg(interp, part1, part2, "unset", 
		    (part2 == NULL) ? noSuchVar : noSuchElement);
	}
	return -1;
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar --
 *
 *	Arrange for reads and/or writes to a variable to cause a
 *	procedure to be invoked, which can monitor the operations
 *	and/or change their actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by varName, such that
 *	future references to the variable will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    char *varName;		/* Name of variable;  may end with "(index)"
				 * to signify an array reference. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    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 == '(') {
	    int result;
	    char *open = p;

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

    scalar:
    return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
	    proc, clientData);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceVar2 --
 *
 *	Arrange for reads and/or writes to a variable to cause a
 *	procedure to be invoked, which can monitor the operations
 *	and/or change their actions.
 *
 * Results:
 *	A standard Tcl return value.
 *
 * Side effects:
 *	A trace is set up on the variable given by part1 and part2, such
 *	that future references to the variable will be intermediated by
 *	proc.  See the manual entry for complete details on the calling
 *	sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
    Tcl_Interp *interp;		/* Interpreter in which variable is
				 * to be traced. */
    char *part1;		/* Name of scalar variable or array. */
    char *part2;		/* Name of element within array;  NULL means
				 * trace applies to scalar variable or array
				 * as-a-whole. */
    int flags;			/* OR-ed collection of bits, including any
				 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
				 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
    Tcl_VarTraceProc *proc;	/* Procedure to call when specified ops are
				 * invoked upon varName. */
    ClientData clientData;	/* Arbitrary argument to pass to proc. */
{
    Tcl_HashEntry *hPtr;
    Var *varPtr = NULL;		/* Initial value only used to stop compiler
				 * from complaining; not really needed. */
    Interp *iPtr = (Interp *) interp;
    register VarTrace *tracePtr;
    int new;

    /*
     * Locate the variable, making a new (undefined) one if necessary.
     */

    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 the trace is to be on an array element, make sure that the
     * variable is an array variable.  If the variable doesn't exist
     * then define it as an empty array.  Then find the specific
     * array element.
     */

    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)) {
		iPtr->result = needArray;
		return TCL_ERROR;
	    }
	}
	hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
    }

    if (new) {
	if ((part2 != NULL) && (varPtr->searchPtr != NULL)) {
	    DeleteSearches(varPtr);
	}
	varPtr = NewVar(0);
	varPtr->flags = VAR_UNDEFINED;
	Tcl_SetHashValue(hPtr, varPtr);
    } else {
	varPtr = (Var *) Tcl_GetHashValue(hPtr);
    }

    /*
     * Set up trace information.
     */

    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags &