Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part25

Text File | 1991-11-15 | 35.5 KB | 1,197 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i093:  tcl - tool command language, version 6.1, Part25/33
Message-ID: <[e-mail]>
X-Md4-Signature: 8f149172acc91f7fc91b79a979401d2f
Date: Fri, 15 Nov 1991 22:55:10 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 93
Archive-name: tcl/part25
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 25 (of 33)."
# Contents:  tcl6.1/tclVar.c.1
# Wrapped by karl@one on Tue Nov 12 19:44:29 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclVar.c.1' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclVar.c.1'\"
else
echo shar: Extracting \"'tcl6.1/tclVar.c.1'\" \(32992 characters\)
sed "s/^X//" >'tcl6.1/tclVar.c.1' <<'END_OF_FILE'
X/*
X * tclVar.c --
X *
X *    This file contains routines that implement Tcl variables
X *    (both scalars and arrays).
X *
X *    The implementation of arrays is modelled after an initial
X *    implementation by Karl Lehenbauer, Mark Diekhans and
X *    Peter da Silva.
X *
X * Copyright 1987-1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.25 91/10/31 16:41:46 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The strings below are used to indicate what went wrong when a
X * variable access is denied.
X */
X
Xstatic char *noSuchVar =    "no such variable";
Xstatic char *isArray =        "variable is array";
Xstatic char *needArray =    "variable isn't array";
Xstatic char *noSuchElement =    "no such element in array";
Xstatic char *traceActive =    "trace is active on variable";
X
X/*
X * Forward references to procedures defined later in this file:
X */
X
Xstatic  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
X                Tcl_HashEntry *hPtr, char *name1, char *name2,
X                int flags));
Xstatic void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
Xstatic void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
X                Var *varPtr, int flags));
Xstatic Var *        NewVar _ANSI_ARGS_((int space));
Xstatic ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
X                Var *varPtr, char *varName, char *string));
Xstatic void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
X                char *name1, char *name2, char *operation,
X                char *reason));
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GetVar --
X *
X *    Return the value of a Tcl variable.
X *
X * Results:
X *    The return value points to the current value of varName.  If
X *    the variable is not defined or can't be read because of a clash
X *    in array usage then a NULL pointer is returned and an error
X *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
X *    flag is set.  Note:  the return value is only valid up until
X *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
X *    the value lasting longer than that, then make yourself a private
X *    copy.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_GetVar(interp, varName, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which varName is
X                 * to be looked up. */
X    char *varName;        /* Name of a variable in interp. */
X    int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
X                 * or TCL_LEAVE_ERR_MSG bits. */
X{
X    register char *p;
X
X    /*
X     * If varName refers to an array (it ends with a parenthesized
X     * element name), then handle it specially.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        char *result;
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        result = Tcl_GetVar2(interp, varName, open+1, flags);
X        *open = '(';
X        *p = ')';
X        return result;
X    }
X    }
X
X    scalar:
X    return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GetVar2 --
X *
X *    Return the value of a Tcl variable, given a two-part name
X *    consisting of array name and element within array.
X *
X * Results:
X *    The return value points to the current value of the variable
X *    given by name1 and name2.  If the specified variable doesn't
X *    exist, or if there is a clash in array usage, then NULL is
X *    returned and a message will be left in interp->result if the
X *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
X *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
X *    if you depend on the value lasting longer than that, then make
X *    yourself a private copy.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_GetVar2(interp, name1, name2, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which variable is
X                 * to be looked up. */
X    char *name1;        /* Name of array (if name2 is NULL) or
X                 * name of variable. */
X    char *name2;        /* If non-null, gives name of element in
X                 * array. */
X    int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
X                 * or TCL_LEAVE_ERR_MSG bits. */
X{
X    Tcl_HashEntry *hPtr;
X    Var *varPtr;
X    Interp *iPtr = (Interp *) interp;
X    Var *arrayPtr = NULL;
X
X    /*
X     * Lookup the first name.
X     */
X
X    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X    hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X    } else {
X    hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
X    }
X    if (hPtr == NULL) {
X    if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "read", noSuchVar);
X    }
X    return NULL;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_UPVAR) {
X    hPtr = varPtr->value.upvarPtr;
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * If this is an array reference, then remember the traces on the array
X     * and lookup the element within the array.
X     */
X
X    if (name2 != NULL) {
X    if (varPtr->flags & VAR_UNDEFINED) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "read", noSuchVar);
X        }
X        return NULL;
X    } else if (!(varPtr->flags & VAR_ARRAY)) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "read", needArray);
X        }
X        return NULL;
X    }
X    arrayPtr = varPtr;
X    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X    if (hPtr == NULL) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "read", noSuchElement);
X        }
X        return NULL;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * Invoke any traces that have been set for the variable.
X     */
X
X    if ((varPtr->tracePtr != NULL)
X        || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X    char *msg;
X
X    msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
X        (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
X    if (msg != NULL) {
X        VarErrMsg(interp, name1, name2, "read", msg);
X        return NULL;
X    }
X
X    /*
X     * Watch out!  The variable could have gotten re-allocated to
X     * a larger size.  Fortunately the hash table entry will still
X     * be around.
X     */
X
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY)) {
X    if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "read", noSuchVar);
X    }
X    return NULL;
X    }
X    return varPtr->value.string;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetVar --
X *
X *    Change the value of a variable.
X *
X * Results:
X *    Returns a pointer to the malloc'ed string holding the new
X *    value of the variable.  The caller should not modify this
X *    string.  If the write operation was disallowed then NULL
X *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
X *    an explanatory message will be left in interp->result.
X *
X * Side effects:
X *    If varName is defined as a local or global variable in interp,
X *    its value is changed to newValue.  If varName isn't currently
X *    defined, then a new global variable by that name is created.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_SetVar(interp, varName, newValue, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which varName is
X                 * to be looked up. */
X    char *varName;        /* Name of a variable in interp. */
X    char *newValue;        /* New value for varName. */
X    int flags;            /* Various flags that tell how to set value:
X                 * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
X                 * TCL_LIST_ELEMENT, TCL_NO_SPACE, or
X                 * TCL_LEAVE_ERR_MSG. */
X{
X    register char *p;
X
X    /*
X     * If varName refers to an array (it ends with a parenthesized
X     * element name), then handle it specially.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        char *result;
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
X        *open = '(';
X        *p = ')';
X        return result;
X    }
X    }
X
X    scalar:
X    return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetVar2 --
X *
X *    Given a two-part variable name, which may refer either to a
X *    scalar variable or an element of an array, change the value
X *    of the variable.  If the named scalar or array or element
X *    doesn't exist then create one.
X *
X * Results:
X *    Returns a pointer to the malloc'ed string holding the new
X *    value of the variable.  The caller should not modify this
X *    string.  If the write operation was disallowed because an
X *    array was expected but not found (or vice versa), then NULL
X *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
X *    an explanatory message will be left in interp->result.
X *
X * Side effects:
X *    The value of the given variable is set.  If either the array
X *    or the entry didn't exist then a new one is created.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_SetVar2(interp, name1, name2, newValue, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which variable is
X                 * to be looked up. */
X    char *name1;        /* If name2 is NULL, this is name of scalar
X                 * variable.  Otherwise it is name of array. */
X    char *name2;        /* Name of an element within array, or NULL. */
X    char *newValue;        /* New value for variable. */
X    int flags;            /* Various flags that tell how to set value:
X                 * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
X                 * TCL_LIST_ELEMENT, and TCL_NO_SPACE, or
X                 * TCL_LEAVE_ERR_MSG . */
X{
X    Tcl_HashEntry *hPtr;
X    register Var *varPtr = NULL;
X                /* Initial value only used to stop compiler
X                 * from complaining; not really needed. */
X    register Interp *iPtr = (Interp *) interp;
X    int length, new, listFlags;
X    Var *arrayPtr = NULL;
X
X    /*
X     * Lookup the first name.
X     */
X
X    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X    hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
X    } else {
X    hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
X        name1, &new);
X    }
X    if (!new) {
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_UPVAR) {
X        hPtr = varPtr->value.upvarPtr;
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    }
X
X    /*
X     * If this is an array reference, then create a new array (if
X     * needed), remember any traces on the array, and lookup the
X     * element within the array.
X     */
X
X    if (name2 != NULL) {
X    if (new) {
X        varPtr = NewVar(0);
X        Tcl_SetHashValue(hPtr, varPtr);
X        varPtr->flags = VAR_ARRAY;
X        varPtr->value.tablePtr = (Tcl_HashTable *)
X            ckalloc(sizeof(Tcl_HashTable));
X        Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X    } else {
X        if (varPtr->flags & VAR_UNDEFINED) {
X        varPtr->flags = VAR_ARRAY;
X        varPtr->value.tablePtr = (Tcl_HashTable *)
X            ckalloc(sizeof(Tcl_HashTable));
X        Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X        } else if (!(varPtr->flags & VAR_ARRAY)) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X            VarErrMsg(interp, name1, name2, "set", needArray);
X        }
X        return NULL;
X        }
X        arrayPtr = varPtr;
X    }
X    hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
X    }
X
X    /*
X     * Compute how many bytes will be needed for newValue (leave space
X     * for a separating space between list elements).
X     */
X
X    if (flags & TCL_LIST_ELEMENT) {
X    length = Tcl_ScanElement(newValue, &listFlags) + 1;
X    } else {
X    length = strlen(newValue);
X    }
X
X    /*
X     * If the variable doesn't exist then create a new one.  If it
X     * does exist then clear its current value unless this is an
X     * append operation.
X     */
X
X    if (new) {
X    varPtr = NewVar(length);
X    Tcl_SetHashValue(hPtr, varPtr);
X    if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
X        DeleteSearches(arrayPtr);
X    }
X    } else {
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_ARRAY) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "set", isArray);
X        }
X        return NULL;
X    }
X    if (!(flags & TCL_APPEND_VALUE)) {
X        varPtr->valueLength = 0;
X    }
X    }
X
X    /*
X     * Make sure there's enough space to hold the variable's
X     * new value.  If not, enlarge the variable's space.
X     */
X
X    if ((length + varPtr->valueLength) >= varPtr->valueSpace) {
X    Var *newVarPtr;
X    int newSize;
X
X    newSize = 2*varPtr->valueSpace;
X    if (newSize <= (length + varPtr->valueLength)) {
X        newSize += length;
X    }
X    newVarPtr = NewVar(newSize);
X    newVarPtr->valueLength = varPtr->valueLength;
X    newVarPtr->upvarUses = varPtr->upvarUses;
X    newVarPtr->tracePtr = varPtr->tracePtr;
X    strcpy(newVarPtr->value.string, varPtr->value.string);
X    Tcl_SetHashValue(hPtr, newVarPtr);
X    ckfree((char *) varPtr);
X    varPtr = newVarPtr;
X    }
X
X    /*
X     * Append the new value to the variable, either as a list
X     * element or as a string.
X     */
X
X    if (flags & TCL_LIST_ELEMENT) {
X    if ((varPtr->valueLength > 0) && !(flags & TCL_NO_SPACE)) {
X        varPtr->value.string[varPtr->valueLength] = ' ';
X        varPtr->valueLength++;
X    }
X    varPtr->valueLength += Tcl_ConvertElement(newValue,
X        varPtr->value.string + varPtr->valueLength, listFlags);
X    varPtr->value.string[varPtr->valueLength] = 0;
X    } else {
X    strcpy(varPtr->value.string + varPtr->valueLength, newValue);
X    varPtr->valueLength += length;
X    }
X    varPtr->flags &= ~VAR_UNDEFINED;
X
X    /*
X     * Invoke any write traces for the variable.
X     */
X
X    if ((varPtr->tracePtr != NULL)
X        || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X    char *msg;
X
X    msg = CallTraces(iPtr, arrayPtr, hPtr, name1, name2,
X        (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
X    if (msg != NULL) {
X        VarErrMsg(interp, name1, name2, "set", msg);
X        return NULL;
X    }
X
X    /*
X     * Watch out!  The variable could have gotten re-allocated to
X     * a larger size.  Fortunately the hash table entry will still
X     * be around.
X     */
X
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    return varPtr->value.string;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UnsetVar --
X *
X *    Delete a variable, so that it may not be accessed anymore.
X *
X * Results:
X *    Returns 0 if the variable was successfully deleted, -1
X *    if the variable can't be unset.  In the event of an error,
X *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
X *    is left in interp->result.
X *
X * Side effects:
X *    If varName is defined as a local or global variable in interp,
X *    it is deleted.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_UnsetVar(interp, varName, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which varName is
X                 * to be looked up. */
X    char *varName;        /* Name of a variable in interp.  May be
X                 * either a scalar name or an array name
X                 * or an element in an array. */
X    int flags;            /* OR-ed combination of any of
X                 * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
X{
X    register char *p;
X    int result;
X
X    /*
X     * Figure out whether this is an array reference, then call
X     * Tcl_UnsetVar2 to do all the real work.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        result = Tcl_UnsetVar2(interp, varName, open+1, flags);
X        *open = '(';
X        *p = ')';
X        return result;
X    }
X    }
X
X    scalar:
X    return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UnsetVar2 --
X *
X *    Delete a variable, given a 2-part name.
X *
X * Results:
X *    Returns 0 if the variable was successfully deleted, -1
X *    if the variable can't be unset.  In the event of an error,
X *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
X *    is left in interp->result.
X *
X * Side effects:
X *    If name1 and name2 indicate a local or global variable in interp,
X *    it is deleted.  If name1 is an array name and name2 is NULL, then
X *    the whole array is deleted.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_UnsetVar2(interp, name1, name2, flags)
X    Tcl_Interp *interp;        /* Command interpreter in which varName is
X                 * to be looked up. */
X    char *name1;        /* Name of variable or array. */
X    char *name2;        /* Name of element within array or NULL. */
X    int flags;            /* OR-ed combination of any of
X                 * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
X{
X    Tcl_HashEntry *hPtr, dummyEntry;
X    Var *varPtr, dummyVar;
X    Interp *iPtr = (Interp *) interp;
X    Var *arrayPtr = NULL;
X
X    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X    hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X    } else {
X    hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
X    }
X    if (hPtr == NULL) {
X    if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "unset", noSuchVar);
X    }
X    return -1;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X
X    /*
X     * For global variables referenced in procedures, leave the procedure's
X     * reference variable in place, but unset the global variable.  Can't
X     * decrement the actual variable's use count, since we didn't delete
X     * the reference variable.
X     */
X
X    if (varPtr->flags & VAR_UPVAR) {
X    hPtr = varPtr->value.upvarPtr;
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * If the variable being deleted is an element of an array, then
X     * remember trace procedures on the overall array and find the
X     * element to delete.
X     */
X
X    if (name2 != NULL) {
X    if (!(varPtr->flags & VAR_ARRAY)) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "unset", needArray);
X        }
X        return -1;
X    }
X    if (varPtr->searchPtr != NULL) {
X        DeleteSearches(varPtr);
X    }
X    arrayPtr = varPtr;
X    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X    if (hPtr == NULL) {
X        if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "unset", noSuchElement);
X        }
X        return -1;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * If there is a trace active on this variable or if the variable
X     * is already being deleted then don't delete the variable:  it
X     * isn't safe, since there are procedures higher up on the stack
X     * that will use pointers to the variable.  Also don't delete an
X     * array if there are traces active on any of its elements.
X     */
X
X    if (varPtr->flags &
X        (VAR_TRACE_ACTIVE|VAR_ELEMENT_ACTIVE)) {
X    if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "unset", traceActive);
X    }
X    return -1;
X    }
X
X    /*
X     * The code below is tricky, because of the possibility that
X     * a trace procedure might try to access a variable being
X     * deleted.  To handle this situation gracefully, copy the
X     * contents of the variable and its hash table entry to
X     * dummy variables, then clean up the actual variable so that
X     * it's been completely deleted before the traces are called.
X     * Then call the traces, and finally clean up the variable's
X     * storage using the dummy copies.
X     */
X
X    dummyVar = *varPtr;
X    Tcl_SetHashValue(&dummyEntry, &dummyVar);
X    if (varPtr->upvarUses == 0) {
X    Tcl_DeleteHashEntry(hPtr);
X    ckfree((char *) varPtr);
X    } else {
X    varPtr->flags = VAR_UNDEFINED;
X    varPtr->tracePtr = NULL;
X    }
X
X    /*
X     * Call trace procedures for the variable being deleted and delete
X     * its traces.
X     */
X
X    if ((dummyVar.tracePtr != NULL)
X        || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
X    (void) CallTraces(iPtr, arrayPtr, &dummyEntry, name1, name2,
X        (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
X    while (dummyVar.tracePtr != NULL) {
X        VarTrace *tracePtr = dummyVar.tracePtr;
X        dummyVar.tracePtr = tracePtr->nextPtr;
X        ckfree((char *) tracePtr);
X    }
X    }
X
X    /*
X     * If the variable is an array, delete all of its elements.  This
X     * must be done after calling the traces on the array, above (that's
X     * the way traces are defined).
X     */
X
X    if (dummyVar.flags & VAR_ARRAY) {
X    DeleteArray(iPtr, name1, &dummyVar,
X        (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
X    }
X    if (dummyVar.flags & VAR_UNDEFINED) {
X    if (flags & TCL_LEAVE_ERR_MSG) {
X        VarErrMsg(interp, name1, name2, "set",
X            (name2 != NULL) ? noSuchVar : noSuchElement);
X    }
X    return -1;
X    }
X    return 0;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_TraceVar --
X *
X *    Arrange for reads and/or writes to a variable to cause a
X *    procedure to be invoked, which can monitor the operations
X *    and/or change their actions.
X *
X * Results:
X *    A standard Tcl return value.
X *
X * Side effects:
X *    A trace is set up on the variable given by varName, such that
X *    future references to the variable will be intermediated by
X *    proc.  See the manual entry for complete details on the calling
X *    sequence for proc.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_TraceVar(interp, varName, flags, proc, clientData)
X    Tcl_Interp *interp;        /* Interpreter in which variable is
X                 * to be traced. */
X    char *varName;        /* Name of variable;  may end with "(index)"
X                 * to signify an array reference. */
X    int flags;            /* OR-ed collection of bits, including any
X                 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
X                 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X    Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
X                 * invoked upon varName. */
X    ClientData clientData;    /* Arbitrary argument to pass to proc. */
X{
X    register char *p;
X
X    /*
X     * If varName refers to an array (it ends with a parenthesized
X     * element name), then handle it specially.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        int result;
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        result = Tcl_TraceVar2(interp, varName, open+1, flags,
X            proc, clientData);
X        *open = '(';
X        *p = ')';
X        return result;
X    }
X    }
X
X    scalar:
X    return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
X        proc, clientData);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_TraceVar2 --
X *
X *    Arrange for reads and/or writes to a variable to cause a
X *    procedure to be invoked, which can monitor the operations
X *    and/or change their actions.
X *
X * Results:
X *    A standard Tcl return value.
X *
X * Side effects:
X *    A trace is set up on the variable given by name1 and name2, such
X *    that future references to the variable will be intermediated by
X *    proc.  See the manual entry for complete details on the calling
X *    sequence for proc.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_TraceVar2(interp, name1, name2, flags, proc, clientData)
X    Tcl_Interp *interp;        /* Interpreter in which variable is
X                 * to be traced. */
X    char *name1;        /* Name of scalar variable or array. */
X    char *name2;        /* Name of element within array;  NULL means
X                 * trace applies to scalar variable or array
X                 * as-a-whole. */
X    int flags;            /* OR-ed collection of bits, including any
X                 * of TCL_TRACE_READS, TCL_TRACE_WRITES,
X                 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X    Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
X                 * invoked upon varName. */
X    ClientData clientData;    /* Arbitrary argument to pass to proc. */
X{
X    Tcl_HashEntry *hPtr;
X    Var *varPtr = NULL;        /* Initial value only used to stop compiler
X                 * from complaining; not really needed. */
X    Interp *iPtr = (Interp *) interp;
X    register VarTrace *tracePtr;
X    int new;
X
X    /*
X     * Locate the variable, making a new (undefined) one if necessary.
X     */
X
X    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X    hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, name1, &new);
X    } else {
X    hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, name1, &new);
X    }
X    if (!new) {
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_UPVAR) {
X        hPtr = varPtr->value.upvarPtr;
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    }
X
X    /*
X     * If the trace is to be on an array element, make sure that the
X     * variable is an array variable.  If the variable doesn't exist
X     * then define it as an empty array.  Then find the specific
X     * array element.
X     */
X
X    if (name2 != NULL) {
X    if (new) {
X        varPtr = NewVar(0);
X        Tcl_SetHashValue(hPtr, varPtr);
X        varPtr->flags = VAR_ARRAY;
X        varPtr->value.tablePtr = (Tcl_HashTable *)
X            ckalloc(sizeof(Tcl_HashTable));
X        Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X    } else {
X        if (varPtr->flags & VAR_UNDEFINED) {
X        varPtr->flags = VAR_ARRAY;
X        varPtr->value.tablePtr = (Tcl_HashTable *)
X            ckalloc(sizeof(Tcl_HashTable));
X        Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
X        } else if (!(varPtr->flags & VAR_ARRAY)) {
X        iPtr->result = needArray;
X        return TCL_ERROR;
X        }
X    }
X    hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, name2, &new);
X    }
X
X    if (new) {
X    if ((name2 != NULL) && (varPtr->searchPtr != NULL)) {
X        DeleteSearches(varPtr);
X    }
X    varPtr = NewVar(0);
X    varPtr->flags = VAR_UNDEFINED;
X    Tcl_SetHashValue(hPtr, varPtr);
X    } else {
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * Set up trace information.
X     */
X
X    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
X    tracePtr->traceProc = proc;
X    tracePtr->clientData = clientData;
X    tracePtr->flags = flags &
X        (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
X    tracePtr->nextPtr = varPtr->tracePtr;
X    varPtr->tracePtr = tracePtr;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UntraceVar --
X *
X *    Remove a previously-created trace for a variable.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    If there exists a trace for the variable given by varName
X *    with the given flags, proc, and clientData, then that trace
X *    is removed.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_UntraceVar(interp, varName, flags, proc, clientData)
X    Tcl_Interp *interp;        /* Interpreter containing traced variable. */
X    char *varName;        /* Name of variable;  may end with "(index)"
X                 * to signify an array reference. */
X    int flags;            /* OR-ed collection of bits describing
X                 * current trace, including any of
X                 * TCL_TRACE_READS, TCL_TRACE_WRITES,
X                 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X    Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
X    ClientData clientData;    /* Arbitrary argument to pass to proc. */
X{
X    register char *p;
X
X    /*
X     * If varName refers to an array (it ends with a parenthesized
X     * element name), then handle it specially.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
X        *open = '(';
X        *p = ')';
X        return;
X    }
X    }
X
X    scalar:
X    Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UntraceVar2 --
X *
X *    Remove a previously-created trace for a variable.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    If there exists a trace for the variable given by name1
X *    and name2 with the given flags, proc, and clientData, then
X *    that trace is removed.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_UntraceVar2(interp, name1, name2, flags, proc, clientData)
X    Tcl_Interp *interp;        /* Interpreter containing traced variable. */
X    char *name1;        /* Name of variable or array. */
X    char *name2;        /* Name of element within array;  NULL means
X                 * trace applies to scalar variable or array
X                 * as-a-whole. */
X    int flags;            /* OR-ed collection of bits describing
X                 * current trace, including any of
X                 * TCL_TRACE_READS, TCL_TRACE_WRITES,
X                 * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
X    Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
X    ClientData clientData;    /* Arbitrary argument to pass to proc. */
X{
X    register VarTrace *tracePtr;
X    VarTrace *prevPtr;
X    Var *varPtr;
X    Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr;
X    ActiveVarTrace *activePtr;
X
X    /*
X     * First, lookup the variable.
X     */
X
X    if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
X    hPtr = Tcl_FindHashEntry(&iPtr->globalTable, name1);
X    } else {
X    hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, name1);
X    }
X    if (hPtr == NULL) {
X    return;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_UPVAR) {
X    hPtr = varPtr->value.upvarPtr;
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    if (name2 != NULL) {
X    if (!(varPtr->flags & VAR_ARRAY)) {
X        return;
X    }
X    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X    if (hPtr == NULL) {
X        return;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
X    for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
X        prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
X    if (tracePtr == NULL) {
X        return;
X    }
X    if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
X        && (tracePtr->clientData == clientData)) {
X        break;
X    }
X    }
X
X    /*
X     * The code below makes it possible to delete traces while traces
X     * are active:  it makes sure that the deleted trace won't be
X     * processed by CallTraces.
X     */
X
X    for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
X        activePtr = activePtr->nextPtr) {
X    if (activePtr->nextTracePtr == tracePtr) {
X        activePtr->nextTracePtr = tracePtr->nextPtr;
X    }
X    }
X    if (prevPtr == NULL) {
X    varPtr->tracePtr = tracePtr->nextPtr;
X    } else {
X    prevPtr->nextPtr = tracePtr->nextPtr;
X    }
X    ckfree((char *) tracePtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_VarTraceInfo --
X *
X *    Return the clientData value associated with a trace on a
X *    variable.  This procedure can also be used to step through
X *    all of the traces on a particular variable that have the
X *    same trace procedure.
X *
X * Results:
X *    The return value is the clientData value associated with
X *    a trace on the given variable.  Information will only be
X *    returned for a trace with proc as trace procedure.  If
X *    the clientData argument is NULL then the first such trace is
X *    returned;  otherwise, the next relevant one after the one
X *    given by clientData will be returned.  If the variable
X *    doesn't exist, or if there are no (more) traces for it,
X *    then NULL is returned.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XClientData
XTcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
X    Tcl_Interp *interp;        /* Interpreter containing variable. */
X    char *varName;        /* Name of variable;  may end with "(index)"
X                 * to signify an array reference. */
X    int flags;            /* 0 or TCL_GLOBAL_ONLY. */
X    Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
X    ClientData prevClientData;    /* If non-NULL, gives last value returned
X                 * by this procedure, so this call will
X                 * return the next trace after that one.
X                 * If NULL, this call will return the
X                 * first trace. */
X{
X    register char *p;
X
X    /*
X     * If varName refers to an array (it ends with a parenthesized
X     * element name), then handle it specially.
X     */
X
X    for (p = varName; *p != '\0'; p++) {
X    if (*p == '(') {
X        ClientData result;
X        char *open = p;
X
X        do {
X        p++;
X        } while (*p != '\0');
X        p--;
X        if (*p != ')') {
X        goto scalar;
X        }
X        *open = '\0';
X        *p = '\0';
X        result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
X        prevClientData);
X        *open = '(';
X        *p = ')';
X        return result;
X    }
X    }
X
X    scalar:
X    return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
X        prevClientData);
X}
END_OF_FILE
if test 32992 -ne `wc -c <'tcl6.1/tclVar.c.1'`; then
    echo shar: \"'tcl6.1/tclVar.c.1'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclVar.c.1'
fi
echo shar: End of archive 25 \(of 33\).
cp /dev/null ark25isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].