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

Text File | 1991-11-15 | 33.3 KB | 1,183 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i090:  tcl - tool command language, version 6.1, Part22/33
Message-ID: <[e-mail]>
X-Md4-Signature: a08a34334a783d96d89dbc9675e9c035
Date: Fri, 15 Nov 1991 22:52:00 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 90
Archive-name: tcl/part22
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 22 (of 33)."
# Contents:  tcl6.1/tclVar.c.2
# Wrapped by karl@one on Tue Nov 12 19:44:28 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclVar.c.2' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclVar.c.2'\"
else
echo shar: Extracting \"'tcl6.1/tclVar.c.2'\" \(30825 characters\)
sed "s/^X//" >'tcl6.1/tclVar.c.2' <<'END_OF_FILE'
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_VarTraceInfo2 --
X *
X *    Same as Tcl_VarTraceInfo, except takes name in two pieces
X *    instead of one.
X *
X * Results:
X *    Same as Tcl_VarTraceInfo.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
XClientData
XTcl_VarTraceInfo2(interp, name1, name2, flags, proc, prevClientData)
X    Tcl_Interp *interp;        /* Interpreter containing 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;            /* 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 VarTrace *tracePtr;
X    Var *varPtr;
X    Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr;
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 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    if (name2 != NULL) {
X    if (!(varPtr->flags & VAR_ARRAY)) {
X        return NULL;
X    }
X    hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, name2);
X    if (hPtr == NULL) {
X        return NULL;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X
X    /*
X     * Find the relevant trace, if any, and return its clientData.
X     */
X
X    tracePtr = varPtr->tracePtr;
X    if (prevClientData != NULL) {
X    for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
X        if ((tracePtr->clientData == prevClientData)
X            && (tracePtr->traceProc == proc)) {
X        tracePtr = tracePtr->nextPtr;
X        break;
X        }
X    }
X    }
X    for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
X    if (tracePtr->traceProc == proc) {
X        return tracePtr->clientData;
X    }
X    }
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetCmd --
X *
X *    This procedure is invoked to process the "set" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    A variable's value may be changed.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_SetCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    register Tcl_Interp *interp;    /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    if (argc == 2) {
X    char *value;
X
X    value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
X    if (value == NULL) {
X        return TCL_ERROR;
X    }
X    interp->result = value;
X    return TCL_OK;
X    } else if (argc == 3) {
X    char *result;
X
X    result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
X    if (result == NULL) {
X        return TCL_ERROR;
X    }
X    interp->result = result;
X    return TCL_OK;
X    } else {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " varName ?newValue?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UnsetCmd --
X *
X *    This procedure is invoked to process the "unset" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_UnsetCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    register Tcl_Interp *interp;    /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int i;
X
X    if (argc < 2) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " varName ?varName ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    for (i = 1; i < argc; i++) {
X    if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != 0) {
X        return TCL_ERROR;
X    }
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AppendCmd --
X *
X *    This procedure is invoked to process the "append" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    A variable's value may be changed.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_AppendCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    register Tcl_Interp *interp;    /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int i;
X    char *result = NULL;        /* (Initialization only needed to keep
X                     * the compiler from complaining) */
X
X    if (argc < 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " varName value ?value ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    for (i = 2; i < argc; i++) {
X    result = Tcl_SetVar(interp, argv[1], argv[i],
X        TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
X    if (result == NULL) {
X        return TCL_ERROR;
X    }
X    }
X    interp->result = result;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_LappendCmd --
X *
X *    This procedure is invoked to process the "lappend" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    A variable's value may be changed.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_LappendCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    register Tcl_Interp *interp;    /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int i;
X    char *result = NULL;        /* (Initialization only needed to keep
X                     * the compiler from complaining) */
X
X    if (argc < 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " varName value ?value ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    for (i = 2; i < argc; i++) {
X    result = Tcl_SetVar(interp, argv[1], argv[i],
X        TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
X    if (result == NULL) {
X        return TCL_ERROR;
X    }
X    }
X    interp->result = result;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ArrayCmd --
X *
X *    This procedure is invoked to process the "array" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_ArrayCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    register Tcl_Interp *interp;    /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    int length;
X    char c;
X    Var *varPtr;
X    Tcl_HashEntry *hPtr;
X    Interp *iPtr = (Interp *) interp;
X
X    if (argc < 3) {
X    Tcl_AppendResult(interp, "wrong # args: should be \"",
X        argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Locate the array variable (and it better be an array).
X     */
X
X    if (iPtr->varFramePtr == NULL) {
X    hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
X    } else {
X    hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
X    }
X    if (hPtr == NULL) {
X    notArray:
X    Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
X        (char *) NULL);
X    return TCL_ERROR;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_UPVAR) {
X    varPtr = (Var *) Tcl_GetHashValue(varPtr->value.upvarPtr);
X    }
X    if (!(varPtr->flags & VAR_ARRAY)) {
X    goto notArray;
X    }
X
X    /*
X     * Dispatch based on the option.
X     */
X
X    c = argv[1][0];
X    length = strlen(argv[1]);
X    if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
X    ArraySearch *searchPtr;
X
X    if (argc != 4) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " anymore arrayName searchId\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X    if (searchPtr == NULL) {
X        return TCL_ERROR;
X    }
X    while (1) {
X        Var *varPtr2;
X
X        if (searchPtr->nextEntry != NULL) {
X        varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
X        if (!(varPtr2->flags & VAR_UNDEFINED)) {
X            break;
X        }
X        }
X        searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
X        if (searchPtr->nextEntry == NULL) {
X        interp->result = "0";
X        return TCL_OK;
X        }
X    }
X    interp->result = "1";
X    return TCL_OK;
X    } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
X    ArraySearch *searchPtr, *prevPtr;
X
X    if (argc != 4) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " donesearch arrayName searchId\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X    if (searchPtr == NULL) {
X        return TCL_ERROR;
X    }
X    if (varPtr->searchPtr == searchPtr) {
X        varPtr->searchPtr = searchPtr->nextPtr;
X    } else {
X        for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
X        if (prevPtr->nextPtr == searchPtr) {
X            prevPtr->nextPtr = searchPtr->nextPtr;
X            break;
X        }
X        }
X    }
X    ckfree((char *) searchPtr);
X    } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
X        && (length >= 2)) {
X    Tcl_HashSearch search;
X    Var *varPtr2;
X
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " names arrayName\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr2->flags & VAR_UNDEFINED) {
X        continue;
X        }
X        Tcl_AppendElement(interp,
X            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), 0);
X    }
X    } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
X        && (length >= 2)) {
X    ArraySearch *searchPtr;
X    Tcl_HashEntry *hPtr;
X
X    if (argc != 4) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " nextelement arrayName searchId\"",
X            (char *) NULL);
X        return TCL_ERROR;
X    }
X    searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
X    if (searchPtr == NULL) {
X        return TCL_ERROR;
X    }
X    while (1) {
X        Var *varPtr2;
X
X        hPtr = searchPtr->nextEntry;
X        if (hPtr == NULL) {
X        hPtr = Tcl_NextHashEntry(&searchPtr->search);
X        if (hPtr == NULL) {
X            return TCL_OK;
X        }
X        } else {
X        searchPtr->nextEntry = NULL;
X        }
X        varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X        if (!(varPtr2->flags & VAR_UNDEFINED)) {
X        break;
X        }
X    }
X    interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
X    } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
X        && (length >= 2)) {
X    Tcl_HashSearch search;
X    Var *varPtr2;
X    int size;
X
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " size arrayName\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    size = 0;
X    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X        varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
X        if (varPtr2->flags & VAR_UNDEFINED) {
X        continue;
X        }
X        size++;
X    }
X    sprintf(interp->result, "%d", size);
X    } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
X        && (length >= 2)) {
X    ArraySearch *searchPtr;
X
X    if (argc != 3) {
X        Tcl_AppendResult(interp, "wrong # args: should be \"",
X            argv[0], " startsearch arrayName\"", (char *) NULL);
X        return TCL_ERROR;
X    }
X    searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
X    if (varPtr->searchPtr == NULL) {
X        searchPtr->id = 1;
X        Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
X    } else {
X        char string[20];
X
X        searchPtr->id = varPtr->searchPtr->id + 1;
X        sprintf(string, "%d", searchPtr->id);
X        Tcl_AppendResult(interp, "s-", string, "-", argv[2],
X            (char *) NULL);
X    }
X    searchPtr->varPtr = varPtr;
X    searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
X        &searchPtr->search);
X    searchPtr->nextPtr = varPtr->searchPtr;
X    varPtr->searchPtr = searchPtr;
X    } else {
X    Tcl_AppendResult(interp, "bad option \"", argv[1],
X        "\": should be anymore, donesearch, names, nextelement, ",
X        "size, or startsearch", (char *) NULL);
X    return TCL_ERROR;
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_GlobalCmd --
X *
X *    This procedure is invoked to process the "global" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_GlobalCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    Var *varPtr, *gVarPtr;
X    register Interp *iPtr = (Interp *) interp;
X    Tcl_HashEntry *hPtr, *hPtr2;
X    int new;
X
X    if (argc < 2) {
X    Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
X        argv[0], " varName ?varName ...?\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    if (iPtr->varFramePtr == NULL) {
X    return TCL_OK;
X    }
X
X    for (argc--, argv++; argc > 0; argc--, argv++) {
X    hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, *argv, &new);
X    if (new) {
X        gVarPtr = NewVar(0);
X        gVarPtr->flags |= VAR_UNDEFINED;
X        Tcl_SetHashValue(hPtr, gVarPtr);
X    } else {
X        gVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X    }
X    hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, *argv, &new);
X    if (!new) {
X        Var *varPtr;
X        varPtr = (Var *) Tcl_GetHashValue(hPtr2);
X        if (varPtr->flags & VAR_UPVAR) {
X        continue;
X        } else {
X        Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", *argv,
X            "\" already exists", (char *) NULL);
X        return TCL_ERROR;
X        }
X    }
X    varPtr = NewVar(0);
X    varPtr->flags |= VAR_UPVAR;
X    varPtr->value.upvarPtr = hPtr;
X    gVarPtr->upvarUses++;
X    Tcl_SetHashValue(hPtr2, varPtr);
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_UpvarCmd --
X *
X *    This procedure is invoked to process the "upvar" Tcl command.
X *    See the user documentation for details on what it does.
X *
X * Results:
X *    A standard Tcl result value.
X *
X * Side effects:
X *    See the user documentation.
X *
X *----------------------------------------------------------------------
X */
X
X    /* ARGSUSED */
Xint
XTcl_UpvarCmd(dummy, interp, argc, argv)
X    ClientData dummy;            /* Not used. */
X    Tcl_Interp *interp;            /* Current interpreter. */
X    int argc;                /* Number of arguments. */
X    char **argv;            /* Argument strings. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int result;
X    CallFrame *framePtr;
X    Var *varPtr = NULL;
X    Tcl_HashTable *upVarTablePtr;
X    Tcl_HashEntry *hPtr, *hPtr2;
X    int new;
X    Var *upVarPtr;
X
X    if (argc < 3) {
X    upvarSyntax:
X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
X        " ?level? otherVar localVar ?otherVar localVar ...?\"",
X        (char *) NULL);
X    return TCL_ERROR;
X    }
X
X    /*
X     * Find the hash table containing the variable being referenced.
X     */
X
X    result = TclGetFrame(interp, argv[1], &framePtr);
X    if (result == -1) {
X    return TCL_ERROR;
X    }
X    argc -= result+1;
X    argv += result+1;
X    if (framePtr == NULL) {
X    upVarTablePtr = &iPtr->globalTable;
X    } else {
X    upVarTablePtr = &framePtr->varTable;
X    }
X
X    if ((argc & 1) != 0) {
X    goto upvarSyntax;
X    }
X
X    /*
X     * Iterate over all the pairs of (local variable, other variable)
X     * names.  For each pair, create a hash table entry in the upper
X     * context (if the name wasn't there already), then associate it
X     * with a new local variable.
X     */
X
X    while (argc > 0) {
X        hPtr = Tcl_CreateHashEntry(upVarTablePtr, argv[0], &new);
X        if (new) {
X            upVarPtr = NewVar(0);
X            upVarPtr->flags |= VAR_UNDEFINED;
X            Tcl_SetHashValue(hPtr, upVarPtr);
X        } else {
X            upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X        if (upVarPtr->flags & VAR_UPVAR) {
X        hPtr = upVarPtr->value.upvarPtr;
X        upVarPtr = (Var *) Tcl_GetHashValue(hPtr);
X        }
X        }
X
X        hPtr2 = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable,
X                    argv[1], &new);
X        if (!new) {
X            Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", argv[1],
X                "\" already exists", (char *) NULL);
X            return TCL_ERROR;
X        }
X        varPtr = NewVar(0);
X        varPtr->flags |= VAR_UPVAR;
X        varPtr->value.upvarPtr = hPtr;
X        upVarPtr->upvarUses++;
X        Tcl_SetHashValue(hPtr2, varPtr);
X
X        argc -= 2;
X        argv += 2;
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclDeleteVars --
X *
X *    This procedure is called to recycle all the storage space
X *    associated with a table of variables.  For this procedure
X *    to work correctly, it must not be possible for any of the
X *    variable in the table to be accessed from Tcl commands
X *    (e.g. from trace procedures).
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    Variables are deleted and trace procedures are invoked, if
X *    any are declared.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTclDeleteVars(iPtr, tablePtr)
X    Interp *iPtr;        /* Interpreter to which variables belong. */
X    Tcl_HashTable *tablePtr;    /* Hash table containing variables to
X                 * delete. */
X{
X    Tcl_HashSearch search;
X    Tcl_HashEntry *hPtr;
X    register Var *varPtr;
X    int flags, globalFlag;
X
X    flags = TCL_TRACE_UNSETS;
X    if (tablePtr == &iPtr->globalTable) {
X    flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
X    }
X    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
X        hPtr = Tcl_NextHashEntry(&search)) {
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X
X    /*
X     * For global/upvar variables referenced in procedures, free up the
X     * local space and then decrement the reference count on the
X     * variable referred to.  If there are no more references to the
X     * global/upvar and it is undefined and has no traces set, then
X     * follow on and delete the referenced variable too.
X     */
X
X    globalFlag = 0;
X    if (varPtr->flags & VAR_UPVAR) {
X        hPtr = varPtr->value.upvarPtr;
X        ckfree((char *) varPtr);
X        varPtr = (Var *) Tcl_GetHashValue(hPtr);
X        varPtr->upvarUses--;
X        if ((varPtr->upvarUses != 0) || !(varPtr->flags & VAR_UNDEFINED)
X            || (varPtr->tracePtr != NULL)) {
X        continue;
X        }
X        globalFlag = TCL_GLOBAL_ONLY;
X    }
X
X    /*
X     * Invoke traces on the variable that is being deleted, then
X     * free up the variable's space (no need to free the hash entry
X     * here, unless we're dealing with a global variable:  the
X     * hash entries will be deleted automatically when the whole
X     * table is deleted).
X     */
X
X    if (varPtr->tracePtr != NULL) {
X        (void) CallTraces(iPtr, (Var *) NULL, hPtr,
X            Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL,
X            flags | globalFlag);
X        while (varPtr->tracePtr != NULL) {
X        VarTrace *tracePtr = varPtr->tracePtr;
X        varPtr->tracePtr = tracePtr->nextPtr;
X        ckfree((char *) tracePtr);
X        }
X    }
X    if (varPtr->flags & VAR_ARRAY) {
X        DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr,
X            flags | globalFlag);
X    }
X    if (globalFlag) {
X        Tcl_DeleteHashEntry(hPtr);
X    }
X    ckfree((char *) varPtr);
X    }
X    Tcl_DeleteHashTable(tablePtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * CallTraces --
X *
X *    This procedure is invoked to find and invoke relevant
X *    trace procedures associated with a particular operation on
X *    a variable.  This procedure invokes traces both on the
X *    variable and on its containing array (where relevant).
X *
X * Results:
X *    The return value is NULL if no trace procedures were invoked, or
X *    if all the invoked trace procedures returned successfully.
X *    The return value is non-zero if a trace procedure returned an
X *    error (in this case no more trace procedures were invoked after
X *    the error was returned).  In this case the return value is a
X *    pointer to a static string describing the error.
X *
X * Side effects:
X *    Almost anything can happen, depending on trace;  this procedure
X *    itself doesn't have any side effects.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic char *
XCallTraces(iPtr, arrayPtr, hPtr, name1, name2, flags)
X    Interp *iPtr;            /* Interpreter containing variable. */
X    register Var *arrayPtr;        /* Pointer to array variable that
X                     * contains the variable, or NULL if
X                     * the variable isn't an element of an
X                     * array. */
X    Tcl_HashEntry *hPtr;        /* Hash table entry corresponding to
X                     * variable whose traces are to be
X                     * invoked. */
X    char *name1, *name2;        /* Variable's two-part name. */
X    int flags;                /* Flags to pass to trace procedures:
X                     * indicates what's happening to
X                     * variable, plus other stuff like
X                     * TCL_GLOBAL_ONLY and
X                     * TCL_INTERP_DESTROYED. */
X{
X    Var *varPtr;
X    register VarTrace *tracePtr;
X    ActiveVarTrace active;
X    char *result;
X    int savedArrayFlags = 0;        /* (Initialization not needed except
X                     * to prevent compiler warning) */
X
X    /*
X     * If there are already similar trace procedures active for the
X     * variable, don't call them again.
X     */
X
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (varPtr->flags & VAR_TRACE_ACTIVE) {
X    return NULL;
X    }
X    varPtr->flags |= VAR_TRACE_ACTIVE;
X
X    /*
X     * Invoke traces on the array containing the variable, if relevant.
X     */
X
X    result = NULL;
X    active.nextPtr = iPtr->activeTracePtr;
X    iPtr->activeTracePtr = &active;
X    if (arrayPtr != NULL) {
X    savedArrayFlags = arrayPtr->flags;
X    arrayPtr->flags |= VAR_ELEMENT_ACTIVE;
X    for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
X        tracePtr = active.nextTracePtr) {
X        active.nextTracePtr = tracePtr->nextPtr;
X        if (!(tracePtr->flags & flags)) {
X        continue;
X        }
X        result = (*tracePtr->traceProc)(tracePtr->clientData,
X            (Tcl_Interp *) iPtr, name1, name2, flags);
X        if (result != NULL) {
X        if (flags & TCL_TRACE_UNSETS) {
X            result = NULL;
X        } else {
X            goto done;
X        }
X        }
X    }
X    }
X
X    /*
X     * Invoke traces on the variable itself.
X     */
X
X    if (flags & TCL_TRACE_UNSETS) {
X    flags |= TCL_TRACE_DESTROYED;
X    }
X    for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
X        tracePtr = active.nextTracePtr) {
X    active.nextTracePtr = tracePtr->nextPtr;
X    if (!(tracePtr->flags & flags)) {
X        continue;
X    }
X    result = (*tracePtr->traceProc)(tracePtr->clientData,
X        (Tcl_Interp *) iPtr, name1, name2, flags);
X    if (result != NULL) {
X        if (flags & TCL_TRACE_UNSETS) {
X        result = NULL;
X        } else {
X        goto done;
X        }
X    }
X    }
X
X    /*
X     * Restore the variable's flags, remove the record of our active
X     * traces, and then return.  Remember that the variable could have
X     * been re-allocated during the traces, but its hash entry won't
X     * change.
X     */
X
X    done:
X    if (arrayPtr != NULL) {
X    arrayPtr->flags = savedArrayFlags;
X    }
X    varPtr = (Var *) Tcl_GetHashValue(hPtr);
X    varPtr->flags &= ~VAR_TRACE_ACTIVE;
X    iPtr->activeTracePtr = active.nextPtr;
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * NewVar --
X *
X *    Create a new variable with a given initial value.
X *
X * Results:
X *    The return value is a pointer to the new variable structure.
X *    The variable will not be part of any hash table yet, and its
X *    upvarUses count is initialized to 0.  Its initial value will
X *    be empty, but "space" bytes will be available in the value
X *    area.
X *
X * Side effects:
X *    Storage gets allocated.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic Var *
XNewVar(space)
X    int space;        /* Minimum amount of space to allocate
X             * for variable's value. */
X{
X    int extra;
X    register Var *varPtr;
X
X    extra = space - sizeof(varPtr->value);
X    if (extra < 0) {
X    extra = 0;
X    space = sizeof(varPtr->value);
X    }
X    varPtr = (Var *) ckalloc((unsigned) (sizeof(Var) + extra));
X    varPtr->valueLength = 0;
X    varPtr->valueSpace = space;
X    varPtr->upvarUses = 0;
X    varPtr->tracePtr = NULL;
X    varPtr->searchPtr = NULL;
X    varPtr->flags = 0;
X    varPtr->value.string[0] = 0;
X    return varPtr;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * ParseSearchId --
X *
X *    This procedure translates from a string to a pointer to an
X *    active array search (if there is one that matches the string).
X *
X * Results:
X *    The return value is a pointer to the array search indicated
X *    by string, or NULL if there isn't one.  If NULL is returned,
X *    interp->result contains an error message.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic ArraySearch *
XParseSearchId(interp, varPtr, varName, string)
X    Tcl_Interp *interp;        /* Interpreter containing variable. */
X    Var *varPtr;        /* Array variable search is for. */
X    char *varName;        /* Name of array variable that search is
X                 * supposed to be for. */
X    char *string;        /* String containing id of search.  Must have
X                 * form "search-num-var" where "num" is a
X                 * decimal number and "var" is a variable
X                 * name. */
X{
X    char *end;
X    int id;
X    ArraySearch *searchPtr;
X
X    /*
X     * Parse the id into the three parts separated by dashes.
X     */
X
X    if ((string[0] != 's') || (string[1] != '-')) {
X    syntax:
X    Tcl_AppendResult(interp, "illegal search identifier \"", string,
X        "\"", (char *) NULL);
X    return NULL;
X    }
X    id = strtoul(string+2, &end, 10);
X    if ((end == (string+2)) || (*end != '-')) {
X    goto syntax;
X    }
X    if (strcmp(end+1, varName) != 0) {
X    Tcl_AppendResult(interp, "search identifier \"", string,
X        "\" isn't for variable \"", varName, "\"", (char *) NULL);
X    return NULL;
X    }
X
X    /*
X     * Search through the list of active searches on the interpreter
X     * to see if the desired one exists.
X     */
X
X    for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
X        searchPtr = searchPtr->nextPtr) {
X    if (searchPtr->id == id) {
X        return searchPtr;
X    }
X    }
X    Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
X        (char *) NULL);
X    return NULL;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * DeleteSearches --
X *
X *    This procedure is called to free up all of the searches
X *    associated with an array variable.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    Memory is released to the storage allocator.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XDeleteSearches(arrayVarPtr)
X    register Var *arrayVarPtr;        /* Variable whose searches are
X                     * to be deleted. */
X{
X    ArraySearch *searchPtr;
X
X    while (arrayVarPtr->searchPtr != NULL) {
X    searchPtr = arrayVarPtr->searchPtr;
X    arrayVarPtr->searchPtr = searchPtr->nextPtr;
X    ckfree((char *) searchPtr);
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * DeleteArray --
X *
X *    This procedure is called to free up everything in an array
X *    variable.  It's the caller's responsibility to make sure
X *    that the array is no longer accessible before this procedure
X *    is called.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    All storage associated with varPtr's array elements is deleted
X *    (including the hash table).  Any delete trace procedures for
X *    array elements are invoked.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XDeleteArray(iPtr, arrayName, varPtr, flags)
X    Interp *iPtr;            /* Interpreter containing array. */
X    char *arrayName;            /* Name of array (used for trace
X                     * callbacks). */
X    Var *varPtr;            /* Pointer to variable structure. */
X    int flags;                /* Flags to pass to CallTraces:
X                     * TCL_TRACE_UNSETS and sometimes
X                     * TCL_INTERP_DESTROYED and/or
X                     * TCL_GLOBAL_ONLY. */
X{
X    Tcl_HashSearch search;
X    register Tcl_HashEntry *hPtr;
X    register Var *elPtr;
X
X    DeleteSearches(varPtr);
X    for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
X        hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
X    elPtr = (Var *) Tcl_GetHashValue(hPtr);
X    if (elPtr->tracePtr != NULL) {
X        (void) CallTraces(iPtr, (Var *) NULL, hPtr, arrayName,
X            Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
X        while (elPtr->tracePtr != NULL) {
X        VarTrace *tracePtr = elPtr->tracePtr;
X        elPtr->tracePtr = tracePtr->nextPtr;
X        ckfree((char *) tracePtr);
X        }
X    }
X    if (elPtr->flags & VAR_SEARCHES_POSSIBLE) {
X        panic("DeleteArray found searches on array alement!");
X    }
X    ckfree((char *) elPtr);
X    }
X    Tcl_DeleteHashTable(varPtr->value.tablePtr);
X    ckfree((char *) varPtr->value.tablePtr);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * VarErrMsg --
X *
X *    Generate a reasonable error message describing why a variable
X *    operation failed.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    Interp->result is reset to hold a message identifying the
X *    variable given by name1 and name2 and describing why the
X *    variable operation failed.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XVarErrMsg(interp, name1, name2, operation, reason)
X    Tcl_Interp *interp;        /* Interpreter in which to record message. */
X    char *name1, *name2;    /* Variable's two-part name. */
X    char *operation;        /* String describing operation that failed,
X                 * e.g. "read", "set", or "unset". */
X    char *reason;        /* String describing why operation failed. */
X{
X    Tcl_ResetResult(interp);
X    Tcl_AppendResult(interp, "can't ", operation, " \"", name1, (char *) NULL);
X    if (name2 != NULL) {
X    Tcl_AppendResult(interp, "(", name2, ")", (char *) NULL);
X    }
X    Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
X}
END_OF_FILE
if test 30825 -ne `wc -c <'tcl6.1/tclVar.c.2'`; then
    echo shar: \"'tcl6.1/tclVar.c.2'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclVar.c.2'
fi
echo shar: End of archive 22 \(of 33\).
cp /dev/null ark22isdone
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].