home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tclVar.c < prev   
C/C++ Source or Header  |  1993-08-14  |  67KB  |  2,364 lines
  1. /* 
  2.  * tclVar.c --
  3.  *
  4.  *    This file contains routines that implement Tcl variables
  5.  *    (both scalars and arrays).
  6.  *
  7.  *    The implementation of arrays is modelled after an initial
  8.  *    implementation by Mark Diekhans and Karl Lehenbauer.
  9.  *
  10.  * Copyright (c) 1987-1993 The Regents of the University of California.
  11.  * All rights reserved.
  12.  *
  13.  * Permission is hereby granted, without written agreement and without
  14.  * license or royalty fees, to use, copy, modify, and distribute this
  15.  * software and its documentation for any purpose, provided that the
  16.  * above copyright notice and the following two paragraphs appear in
  17.  * all copies of this software.
  18.  * 
  19.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  20.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  21.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  22.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  23.  *
  24.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  25.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  26.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  27.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  28.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  29.  */
  30.  
  31. #ifndef lint
  32. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclVar.c,v 1.44 93/08/14 17:21:34 ouster Exp $ SPRITE (Berkeley)";
  33. #endif
  34.  
  35. #include "tclInt.h"
  36.  
  37. /*
  38.  * The strings below are used to indicate what went wrong when a
  39.  * variable access is denied.
  40.  */
  41.  
  42. static char *noSuchVar =    "no such variable";
  43. static char *isArray =        "variable is array";
  44. static char *needArray =    "variable isn't array";
  45. static char *noSuchElement =    "no such element in array";
  46. static char *danglingUpvar =    "upvar refers to element in deleted array";
  47.  
  48. /*
  49.  * Creation flag values passed in to LookupVar:
  50.  *
  51.  * CRT_PART1 -        1 means create hash table entry for part 1 of
  52.  *            name, if it doesn't already exist.  0 means
  53.  *            return an error if it doesn't exist.
  54.  * CRT_PART2 -        1 means create hash table entry for part 2 of
  55.  *            name, if it doesn't already exist.  0 means
  56.  *            return an error if it doesn't exist.
  57.  */
  58.  
  59. #define CRT_PART1    1
  60. #define CRT_PART2    2
  61.  
  62. /*
  63.  * Forward references to procedures defined later in this file:
  64.  */
  65.  
  66. static  char *        CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
  67.                 Var *varPtr, char *part1, char *part2,
  68.                 int flags));
  69. static void        CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr));
  70. static void        DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
  71. static void        DeleteArray _ANSI_ARGS_((Interp *iPtr, char *arrayName,
  72.                 Var *varPtr, int flags));
  73. static Var *        LookupVar _ANSI_ARGS_((Tcl_Interp *interp, char *part1,
  74.                 char *part2, int flags, char *msg, int create,
  75.                 Var **arrayPtrPtr));
  76. static int        MakeUpvar _ANSI_ARGS_((Interp *iPtr,
  77.                 CallFrame *framePtr, char *otherP1,
  78.                 char *otherP2, char *myName));
  79. static Var *        NewVar _ANSI_ARGS_((void));
  80. static ArraySearch *    ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
  81.                 Var *varPtr, char *varName, char *string));
  82. static void        VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
  83.                 char *part1, char *part2, char *operation,
  84.                 char *reason));
  85.  
  86. /*
  87.  *----------------------------------------------------------------------
  88.  *
  89.  * LookupVar --
  90.  *
  91.  *    This procedure is used by virtually all of the variable
  92.  *    code to locate a variable given its name(s).
  93.  *
  94.  * Results:
  95.  *    The return value is a pointer to the variable indicated by
  96.  *    part1 and part2, or NULL if the variable couldn't be found.
  97.  *    If the variable is found, *arrayPtrPtr is filled in with
  98.  *    the address of the array that contains the variable (or NULL
  99.  *    if the variable is a scalar).  Note:  it's possible that the
  100.  *    variable returned may be VAR_UNDEFINED, even if CRT_PART1 and
  101.  *    CRT_PART2 are specified (these only cause the hash table entry
  102.  *    and/or array to be created).
  103.  *
  104.  * Side effects:
  105.  *    None.
  106.  *
  107.  *----------------------------------------------------------------------
  108.  */
  109.  
  110. static Var *
  111. LookupVar(interp, part1, part2, flags, msg, create, arrayPtrPtr)
  112.     Tcl_Interp *interp;        /* Interpreter to use for lookup. */
  113.     char *part1;        /* If part2 is NULL, this is name of scalar
  114.                  * variable.  Otherwise it is name of array. */
  115.     char *part2;        /* Name of an element within array, or NULL. */
  116.     int flags;            /* Only the TCL_GLOBAL_ONLY and
  117.                  * TCL_LEAVE_ERR_MSG bits matter. */
  118.     char *msg;            /* Verb to use in error messages, e.g.
  119.                  * "read" or "set".  Only needed if
  120.                  * TCL_LEAVE_ERR_MSG is set in flags. */
  121.     int create;            /* OR'ed combination of CRT_PART1 and
  122.                  * CRT_PART2.  Tells which entries to create
  123.                  * if they don't already exist. */
  124.     Var **arrayPtrPtr;        /* If part2 is non-NULL, *arrayPtrPtr gets
  125.                  * filled in with address of array variable. */
  126. {
  127.     Interp *iPtr = (Interp *) interp;
  128.     Tcl_HashTable *tablePtr;
  129.     Tcl_HashEntry *hPtr;
  130.     Var *varPtr;
  131.     int new;
  132.  
  133.     /*
  134.      * Lookup part1.
  135.      */
  136.  
  137.     *arrayPtrPtr = NULL;
  138.     if ((flags & TCL_GLOBAL_ONLY) || (iPtr->varFramePtr == NULL)) {
  139.     tablePtr = &iPtr->globalTable;
  140.     } else {
  141.     tablePtr = &iPtr->varFramePtr->varTable;
  142.     }
  143.     if (create & CRT_PART1) {
  144.     hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new);
  145.     if (new) {
  146.         varPtr = NewVar();
  147.         Tcl_SetHashValue(hPtr, varPtr);
  148.         varPtr->hPtr = hPtr;
  149.     }
  150.     } else {
  151.     hPtr = Tcl_FindHashEntry(tablePtr, part1);
  152.     if (hPtr == NULL) {
  153.         if (flags & TCL_LEAVE_ERR_MSG) {
  154.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  155.         }
  156.         return NULL;
  157.     }
  158.     }
  159.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  160.     if (varPtr->flags & VAR_UPVAR) {
  161.     varPtr = varPtr->value.upvarPtr;
  162.     }
  163.  
  164.     if (part2 == NULL) {
  165.     return varPtr;
  166.     }
  167.  
  168.     /*
  169.      * We're dealing with an array element, so make sure the variable
  170.      * is an array and lookup the element (create it if desired).
  171.      */
  172.  
  173.     if (varPtr->flags & VAR_UNDEFINED) {
  174.     if (!(create & CRT_PART1)) {
  175.         if (flags & TCL_LEAVE_ERR_MSG) {
  176.         VarErrMsg(interp, part1, part2, msg, noSuchVar);
  177.         }
  178.         return NULL;
  179.     }
  180.     varPtr->flags = VAR_ARRAY;
  181.     varPtr->value.tablePtr = (Tcl_HashTable *)
  182.         ckalloc(sizeof(Tcl_HashTable));
  183.     Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
  184.     } else if (!(varPtr->flags & VAR_ARRAY)) {
  185.     if (flags & TCL_LEAVE_ERR_MSG) {
  186.         VarErrMsg(interp, part1, part2, msg, needArray);
  187.     }
  188.     return NULL;
  189.     }
  190.     *arrayPtrPtr = varPtr;
  191.     if (create & CRT_PART2) {
  192.     hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, part2, &new);
  193.     if (new) {
  194.         if (varPtr->searchPtr != NULL) {
  195.         DeleteSearches(varPtr);
  196.         }
  197.         varPtr = NewVar();
  198.         Tcl_SetHashValue(hPtr, varPtr);
  199.         varPtr->hPtr = hPtr;
  200.     }
  201.     } else {
  202.     hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, part2);
  203.     if (hPtr == NULL) {
  204.         if (flags & TCL_LEAVE_ERR_MSG) {
  205.         VarErrMsg(interp, part1, part2, msg, noSuchElement);
  206.         }
  207.         return NULL;
  208.     }
  209.     }
  210.     return (Var *) Tcl_GetHashValue(hPtr);
  211. }
  212.  
  213. /*
  214.  *----------------------------------------------------------------------
  215.  *
  216.  * Tcl_GetVar --
  217.  *
  218.  *    Return the value of a Tcl variable.
  219.  *
  220.  * Results:
  221.  *    The return value points to the current value of varName.  If
  222.  *    the variable is not defined or can't be read because of a clash
  223.  *    in array usage then a NULL pointer is returned and an error
  224.  *    message is left in interp->result if the TCL_LEAVE_ERR_MSG
  225.  *    flag is set.  Note:  the return value is only valid up until
  226.  *    the next call to Tcl_SetVar or Tcl_SetVar2;  if you depend on
  227.  *    the value lasting longer than that, then make yourself a private
  228.  *    copy.
  229.  *
  230.  * Side effects:
  231.  *    None.
  232.  *
  233.  *----------------------------------------------------------------------
  234.  */
  235.  
  236. char *
  237. Tcl_GetVar(interp, varName, flags)
  238.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  239.                  * to be looked up. */
  240.     char *varName;        /* Name of a variable in interp. */
  241.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  242.                  * or TCL_LEAVE_ERR_MSG bits. */
  243. {
  244.     register char *p;
  245.  
  246.     /*
  247.      * If varName refers to an array (it ends with a parenthesized
  248.      * element name), then handle it specially.
  249.      */
  250.  
  251.     for (p = varName; *p != '\0'; p++) {
  252.     if (*p == '(') {
  253.         char *result;
  254.         char *open = p;
  255.  
  256.         do {
  257.         p++;
  258.         } while (*p != '\0');
  259.         p--;
  260.         if (*p != ')') {
  261.         goto scalar;
  262.         }
  263.         *open = '\0';
  264.         *p = '\0';
  265.         result = Tcl_GetVar2(interp, varName, open+1, flags);
  266.         *open = '(';
  267.         *p = ')';
  268.         return result;
  269.     }
  270.     }
  271.  
  272.     scalar:
  273.     return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
  274. }
  275.  
  276. /*
  277.  *----------------------------------------------------------------------
  278.  *
  279.  * Tcl_GetVar2 --
  280.  *
  281.  *    Return the value of a Tcl variable, given a two-part name
  282.  *    consisting of array name and element within array.
  283.  *
  284.  * Results:
  285.  *    The return value points to the current value of the variable
  286.  *    given by part1 and part2.  If the specified variable doesn't
  287.  *    exist, or if there is a clash in array usage, then NULL is
  288.  *    returned and a message will be left in interp->result if the
  289.  *    TCL_LEAVE_ERR_MSG flag is set.  Note:  the return value is
  290.  *    only valid up until the next call to Tcl_SetVar or Tcl_SetVar2;
  291.  *    if you depend on the value lasting longer than that, then make
  292.  *    yourself a private copy.
  293.  *
  294.  * Side effects:
  295.  *    None.
  296.  *
  297.  *----------------------------------------------------------------------
  298.  */
  299.  
  300. char *
  301. Tcl_GetVar2(interp, part1, part2, flags)
  302.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  303.                  * to be looked up. */
  304.     char *part1;        /* Name of array (if part2 is NULL) or
  305.                  * name of variable. */
  306.     char *part2;        /* If non-null, gives name of element in
  307.                  * array. */
  308.     int flags;            /* OR-ed combination of TCL_GLOBAL_ONLY
  309.                  * or TCL_LEAVE_ERR_MSG bits. */
  310. {
  311.     Var *varPtr, *arrayPtr;
  312.     Interp *iPtr = (Interp *) interp;
  313.  
  314.     varPtr = LookupVar(interp, part1, part2, flags, "read", CRT_PART2,
  315.         &arrayPtr);
  316.     if (varPtr == NULL) {
  317.     return NULL;
  318.     }
  319.  
  320.     /*
  321.      * Invoke any traces that have been set for the variable.
  322.      */
  323.  
  324.     if ((varPtr->tracePtr != NULL)
  325.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  326.     char *msg;
  327.  
  328.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  329.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_READS);
  330.     if (msg != NULL) {
  331.         VarErrMsg(interp, part1, part2, "read", msg);
  332.         goto cleanup;
  333.     }
  334.     }
  335.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  336.     return varPtr->value.string;
  337.     }
  338.     if (flags & TCL_LEAVE_ERR_MSG) {
  339.     char *msg;
  340.  
  341.     if ((varPtr->flags & VAR_UNDEFINED) && (arrayPtr != NULL)
  342.         && !(arrayPtr->flags & VAR_UNDEFINED)) {
  343.         msg = noSuchElement;
  344.     } else {
  345.         msg = noSuchVar;
  346.     }
  347.     VarErrMsg(interp, part1, part2, "read", msg);
  348.     }
  349.  
  350.     /*
  351.      * If the variable doesn't exist anymore and no-one's using it,
  352.      * then free up the relevant structures and hash table entries.
  353.      */
  354.  
  355.     cleanup:
  356.     if (varPtr->flags & VAR_UNDEFINED) {
  357.     CleanupVar(varPtr, arrayPtr);
  358.     }
  359.     return NULL;
  360. }
  361.  
  362. /*
  363.  *----------------------------------------------------------------------
  364.  *
  365.  * Tcl_SetVar --
  366.  *
  367.  *    Change the value of a variable.
  368.  *
  369.  * Results:
  370.  *    Returns a pointer to the malloc'ed string holding the new
  371.  *    value of the variable.  The caller should not modify this
  372.  *    string.  If the write operation was disallowed then NULL
  373.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  374.  *    an explanatory message will be left in interp->result.
  375.  *
  376.  * Side effects:
  377.  *    If varName is defined as a local or global variable in interp,
  378.  *    its value is changed to newValue.  If varName isn't currently
  379.  *    defined, then a new global variable by that name is created.
  380.  *
  381.  *----------------------------------------------------------------------
  382.  */
  383.  
  384. char *
  385. Tcl_SetVar(interp, varName, newValue, flags)
  386.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  387.                  * to be looked up. */
  388.     char *varName;        /* Name of a variable in interp. */
  389.     char *newValue;        /* New value for varName. */
  390.     int flags;            /* Various flags that tell how to set value:
  391.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  392.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */
  393. {
  394.     register char *p;
  395.  
  396.     /*
  397.      * If varName refers to an array (it ends with a parenthesized
  398.      * element name), then handle it specially.
  399.      */
  400.  
  401.     for (p = varName; *p != '\0'; p++) {
  402.     if (*p == '(') {
  403.         char *result;
  404.         char *open = p;
  405.  
  406.         do {
  407.         p++;
  408.         } while (*p != '\0');
  409.         p--;
  410.         if (*p != ')') {
  411.         goto scalar;
  412.         }
  413.         *open = '\0';
  414.         *p = '\0';
  415.         result = Tcl_SetVar2(interp, varName, open+1, newValue, flags);
  416.         *open = '(';
  417.         *p = ')';
  418.         return result;
  419.     }
  420.     }
  421.  
  422.     scalar:
  423.     return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
  424. }
  425.  
  426. /*
  427.  *----------------------------------------------------------------------
  428.  *
  429.  * Tcl_SetVar2 --
  430.  *
  431.  *    Given a two-part variable name, which may refer either to a
  432.  *    scalar variable or an element of an array, change the value
  433.  *    of the variable.  If the named scalar or array or element
  434.  *    doesn't exist then create one.
  435.  *
  436.  * Results:
  437.  *    Returns a pointer to the malloc'ed string holding the new
  438.  *    value of the variable.  The caller should not modify this
  439.  *    string.  If the write operation was disallowed because an
  440.  *    array was expected but not found (or vice versa), then NULL
  441.  *    is returned;  if the TCL_LEAVE_ERR_MSG flag is set, then
  442.  *    an explanatory message will be left in interp->result.
  443.  *
  444.  * Side effects:
  445.  *    The value of the given variable is set.  If either the array
  446.  *    or the entry didn't exist then a new one is created.
  447.  *
  448.  *----------------------------------------------------------------------
  449.  */
  450.  
  451. char *
  452. Tcl_SetVar2(interp, part1, part2, newValue, flags)
  453.     Tcl_Interp *interp;        /* Command interpreter in which variable is
  454.                  * to be looked up. */
  455.     char *part1;        /* If part2 is NULL, this is name of scalar
  456.                  * variable.  Otherwise it is name of array. */
  457.     char *part2;        /* Name of an element within array, or NULL. */
  458.     char *newValue;        /* New value for variable. */
  459.     int flags;            /* Various flags that tell how to set value:
  460.                  * any of TCL_GLOBAL_ONLY, TCL_APPEND_VALUE,
  461.                  * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG . */
  462. {
  463.     register Var *varPtr;
  464.     register Interp *iPtr = (Interp *) interp;
  465.     int length, listFlags;
  466.     Var *arrayPtr;
  467.     char *result;
  468.  
  469.     varPtr = LookupVar(interp, part1, part2, flags, "set", CRT_PART1|CRT_PART2,
  470.         &arrayPtr);
  471.     if (varPtr == NULL) {
  472.     return NULL;
  473.     }
  474.  
  475.     /*
  476.      * If the variable's hPtr field is NULL, it means that this is an
  477.      * upvar to an array element where the array was deleted, leaving
  478.      * the element dangling at the end of the upvar.  Generate an error
  479.      * (allowing the variable to be reset would screw up our storage
  480.      * allocation and is meaningless anyway).
  481.      */
  482.  
  483.     if (varPtr->hPtr == NULL) {
  484.     if (flags & TCL_LEAVE_ERR_MSG) {
  485.         VarErrMsg(interp, part1, part2, "set", danglingUpvar);
  486.     }
  487.     return NULL;
  488.     }
  489.  
  490.     /*
  491.      * Clear the variable's current value unless this is an
  492.      * append operation.
  493.      */
  494.  
  495.     if (varPtr->flags & VAR_ARRAY) {
  496.     if (flags & TCL_LEAVE_ERR_MSG) {
  497.         VarErrMsg(interp, part1, part2, "set", isArray);
  498.     }
  499.     return NULL;
  500.     }
  501.     if (!(flags & TCL_APPEND_VALUE) || (varPtr->flags & VAR_UNDEFINED)) {
  502.     varPtr->valueLength = 0;
  503.     }
  504.  
  505.     /*
  506.      * Compute how many total bytes will be needed for the variable's
  507.      * new value (leave space for a separating space between list
  508.      * elements).  Allocate new space for the value if needed.
  509.      */
  510.  
  511.     if (flags & TCL_LIST_ELEMENT) {
  512.     length = Tcl_ScanElement(newValue, &listFlags) + 1;
  513.     } else {
  514.     length = strlen(newValue);
  515.     }
  516.     length += varPtr->valueLength;
  517.     if (length >= varPtr->valueSpace) {
  518.     char *newValue;
  519.     int newSize;
  520.  
  521.     newSize = 2*varPtr->valueSpace;
  522.     if (newSize <= length) {
  523.         newSize = length + 1;
  524.     }
  525.     if (newSize < 24) {
  526.         /*
  527.          * Don't waste time with teensy-tiny variables;  we'll
  528.          * just end up expanding them later.
  529.          */
  530.  
  531.         newSize = 24;
  532.     }
  533.     newValue = ckalloc((unsigned) newSize);
  534.     if (varPtr->valueSpace > 0) {
  535.         strcpy(newValue, varPtr->value.string);
  536.         ckfree(varPtr->value.string);
  537.     }
  538.     varPtr->valueSpace = newSize;
  539.     varPtr->value.string = newValue;
  540.     }
  541.  
  542.     /*
  543.      * Append the new value to the variable, either as a list
  544.      * element or as a string.
  545.      */
  546.  
  547.     if (flags & TCL_LIST_ELEMENT) {
  548.     char *dst = varPtr->value.string + varPtr->valueLength;
  549.  
  550.     if ((varPtr->valueLength > 0) && ((dst[-1] != '{')
  551.         || ((varPtr->valueLength > 1) && (dst[-2] == '\\')))) {
  552.         *dst = ' ';
  553.         dst++;
  554.         varPtr->valueLength++;
  555.     }
  556.     varPtr->valueLength += Tcl_ConvertElement(newValue, dst, listFlags);
  557.     } else {
  558.     strcpy(varPtr->value.string + varPtr->valueLength, newValue);
  559.     varPtr->valueLength = length;
  560.     }
  561.     varPtr->flags &= ~VAR_UNDEFINED;
  562.  
  563.     /*
  564.      * Invoke any write traces for the variable.
  565.      */
  566.  
  567.     if ((varPtr->tracePtr != NULL)
  568.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  569.     char *msg;
  570.  
  571.     msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2,
  572.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_WRITES);
  573.     if (msg != NULL) {
  574.         VarErrMsg(interp, part1, part2, "set", msg);
  575.         result = NULL;
  576.         goto cleanup;
  577.     }
  578.     }
  579.  
  580.     /*
  581.      * If the variable was changed in some gross way by a trace (e.g.
  582.      * it was unset and then recreated as an array) then just return
  583.      * an empty string;  otherwise return the variable's current
  584.      * value.
  585.      */
  586.  
  587.     if (!(varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR|VAR_ARRAY))) {
  588.     return varPtr->value.string;
  589.     }
  590.     result = "";
  591.  
  592.     /*
  593.      * If the variable doesn't exist anymore and no-one's using it,
  594.      * then free up the relevant structures and hash table entries.
  595.      */
  596.  
  597.     cleanup:
  598.     if (varPtr->flags & VAR_UNDEFINED) {
  599.     CleanupVar(varPtr, arrayPtr);
  600.     }
  601.     return result;
  602. }
  603.  
  604. /*
  605.  *----------------------------------------------------------------------
  606.  *
  607.  * Tcl_UnsetVar --
  608.  *
  609.  *    Delete a variable, so that it may not be accessed anymore.
  610.  *
  611.  * Results:
  612.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  613.  *    if the variable can't be unset.  In the event of an error,
  614.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  615.  *    is left in interp->result.
  616.  *
  617.  * Side effects:
  618.  *    If varName is defined as a local or global variable in interp,
  619.  *    it is deleted.
  620.  *
  621.  *----------------------------------------------------------------------
  622.  */
  623.  
  624. int
  625. Tcl_UnsetVar(interp, varName, flags)
  626.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  627.                  * to be looked up. */
  628.     char *varName;        /* Name of a variable in interp.  May be
  629.                  * either a scalar name or an array name
  630.                  * or an element in an array. */
  631.     int flags;            /* OR-ed combination of any of
  632.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  633. {
  634.     register char *p;
  635.     int result;
  636.  
  637.     /*
  638.      * Figure out whether this is an array reference, then call
  639.      * Tcl_UnsetVar2 to do all the real work.
  640.      */
  641.  
  642.     for (p = varName; *p != '\0'; p++) {
  643.     if (*p == '(') {
  644.         char *open = p;
  645.  
  646.         do {
  647.         p++;
  648.         } while (*p != '\0');
  649.         p--;
  650.         if (*p != ')') {
  651.         goto scalar;
  652.         }
  653.         *open = '\0';
  654.         *p = '\0';
  655.         result = Tcl_UnsetVar2(interp, varName, open+1, flags);
  656.         *open = '(';
  657.         *p = ')';
  658.         return result;
  659.     }
  660.     }
  661.  
  662.     scalar:
  663.     return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
  664. }
  665.  
  666. /*
  667.  *----------------------------------------------------------------------
  668.  *
  669.  * Tcl_UnsetVar2 --
  670.  *
  671.  *    Delete a variable, given a 2-part name.
  672.  *
  673.  * Results:
  674.  *    Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
  675.  *    if the variable can't be unset.  In the event of an error,
  676.  *    if the TCL_LEAVE_ERR_MSG flag is set then an error message
  677.  *    is left in interp->result.
  678.  *
  679.  * Side effects:
  680.  *    If part1 and part2 indicate a local or global variable in interp,
  681.  *    it is deleted.  If part1 is an array name and part2 is NULL, then
  682.  *    the whole array is deleted.
  683.  *
  684.  *----------------------------------------------------------------------
  685.  */
  686.  
  687. int
  688. Tcl_UnsetVar2(interp, part1, part2, flags)
  689.     Tcl_Interp *interp;        /* Command interpreter in which varName is
  690.                  * to be looked up. */
  691.     char *part1;        /* Name of variable or array. */
  692.     char *part2;        /* Name of element within array or NULL. */
  693.     int flags;            /* OR-ed combination of any of
  694.                  * TCL_GLOBAL_ONLY or TCL_LEAVE_ERR_MSG. */
  695. {
  696.     Var *varPtr, dummyVar;
  697.     Interp *iPtr = (Interp *) interp;
  698.     Var *arrayPtr;
  699.     ActiveVarTrace *activePtr;
  700.     int result;
  701.  
  702.     varPtr = LookupVar(interp, part1, part2, flags, "unset", 0,  &arrayPtr);
  703.     if (varPtr == NULL) {
  704.     return TCL_ERROR;
  705.     }
  706.     result = (varPtr->flags & VAR_UNDEFINED) ? TCL_ERROR : TCL_OK;
  707.  
  708.     if ((part2 != NULL) && (arrayPtr->searchPtr != NULL)) {
  709.     DeleteSearches(arrayPtr);
  710.     }
  711.  
  712.     /*
  713.      * The code below is tricky, because of the possibility that
  714.      * a trace procedure might try to access a variable being
  715.      * deleted.  To handle this situation gracefully, do things
  716.      * in three steps:
  717.      * 1. Copy the contents of the variable to a dummy variable
  718.      *    structure, and mark the original structure as undefined.
  719.      * 2. Invoke traces and clean up the variable, using the copy.
  720.      * 3. If at the end of this the original variable is still
  721.      *    undefined and has no outstanding references, then delete
  722.      *      it (but it could have gotten recreated by a trace).
  723.      */
  724.  
  725.     dummyVar = *varPtr;
  726.     varPtr->valueSpace = 0;
  727.     varPtr->flags = VAR_UNDEFINED;
  728.     varPtr->tracePtr = NULL;
  729.  
  730.     /*
  731.      * Call trace procedures for the variable being deleted and delete
  732.      * its traces.  Be sure to abort any other traces for the variable
  733.      * that are still pending.  Special tricks:
  734.      * 1. Increment varPtr's refCount around this:  CallTraces will
  735.      *    use dummyVar so it won't increment varPtr's refCount.
  736.      * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
  737.      *    call unset traces even if other traces are pending.
  738.      */
  739.  
  740.     if ((dummyVar.tracePtr != NULL)
  741.         || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
  742.     varPtr->refCount++;
  743.     dummyVar.flags &= ~VAR_TRACE_ACTIVE;
  744.     (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
  745.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  746.     while (dummyVar.tracePtr != NULL) {
  747.         VarTrace *tracePtr = dummyVar.tracePtr;
  748.         dummyVar.tracePtr = tracePtr->nextPtr;
  749.         ckfree((char *) tracePtr);
  750.     }
  751.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  752.         activePtr = activePtr->nextPtr) {
  753.         if (activePtr->varPtr == varPtr) {
  754.         activePtr->nextTracePtr = NULL;
  755.         }
  756.     }
  757.     varPtr->refCount--;
  758.     }
  759.  
  760.     /*
  761.      * If the variable is an array, delete all of its elements.  This
  762.      * must be done after calling the traces on the array, above (that's
  763.      * the way traces are defined).
  764.      */
  765.  
  766.     if (dummyVar.flags & VAR_ARRAY) {
  767.     DeleteArray(iPtr, part1, &dummyVar,
  768.         (flags & TCL_GLOBAL_ONLY) | TCL_TRACE_UNSETS);
  769.     }
  770.     if (dummyVar.valueSpace > 0) {
  771.     ckfree(dummyVar.value.string);
  772.     }
  773.     if (result == TCL_ERROR) {
  774.     if (flags & TCL_LEAVE_ERR_MSG) {
  775.         VarErrMsg(interp, part1, part2, "unset", 
  776.             (part2 == NULL) ? noSuchVar : noSuchElement);
  777.     }
  778.     }
  779.  
  780.     /*
  781.      * Finally, if the variable is truly not in use then free up its
  782.      * record and remove it from the hash table.
  783.      */
  784.  
  785.     CleanupVar(varPtr, arrayPtr);
  786.     return result;
  787. }
  788.  
  789. /*
  790.  *----------------------------------------------------------------------
  791.  *
  792.  * Tcl_TraceVar --
  793.  *
  794.  *    Arrange for reads and/or writes to a variable to cause a
  795.  *    procedure to be invoked, which can monitor the operations
  796.  *    and/or change their actions.
  797.  *
  798.  * Results:
  799.  *    A standard Tcl return value.
  800.  *
  801.  * Side effects:
  802.  *    A trace is set up on the variable given by varName, such that
  803.  *    future references to the variable will be intermediated by
  804.  *    proc.  See the manual entry for complete details on the calling
  805.  *    sequence for proc.
  806.  *
  807.  *----------------------------------------------------------------------
  808.  */
  809.  
  810. int
  811. Tcl_TraceVar(interp, varName, flags, proc, clientData)
  812.     Tcl_Interp *interp;        /* Interpreter in which variable is
  813.                  * to be traced. */
  814.     char *varName;        /* Name of variable;  may end with "(index)"
  815.                  * to signify an array reference. */
  816.     int flags;            /* OR-ed collection of bits, including any
  817.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  818.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  819.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  820.                  * invoked upon varName. */
  821.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  822. {
  823.     register char *p;
  824.  
  825.     /*
  826.      * If varName refers to an array (it ends with a parenthesized
  827.      * element name), then handle it specially.
  828.      */
  829.  
  830.     for (p = varName; *p != '\0'; p++) {
  831.     if (*p == '(') {
  832.         int result;
  833.         char *open = p;
  834.  
  835.         do {
  836.         p++;
  837.         } while (*p != '\0');
  838.         p--;
  839.         if (*p != ')') {
  840.         goto scalar;
  841.         }
  842.         *open = '\0';
  843.         *p = '\0';
  844.         result = Tcl_TraceVar2(interp, varName, open+1, flags,
  845.             proc, clientData);
  846.         *open = '(';
  847.         *p = ')';
  848.         return result;
  849.     }
  850.     }
  851.  
  852.     scalar:
  853.     return Tcl_TraceVar2(interp, varName, (char *) NULL, flags,
  854.         proc, clientData);
  855. }
  856.  
  857. /*
  858.  *----------------------------------------------------------------------
  859.  *
  860.  * Tcl_TraceVar2 --
  861.  *
  862.  *    Arrange for reads and/or writes to a variable to cause a
  863.  *    procedure to be invoked, which can monitor the operations
  864.  *    and/or change their actions.
  865.  *
  866.  * Results:
  867.  *    A standard Tcl return value.
  868.  *
  869.  * Side effects:
  870.  *    A trace is set up on the variable given by part1 and part2, such
  871.  *    that future references to the variable will be intermediated by
  872.  *    proc.  See the manual entry for complete details on the calling
  873.  *    sequence for proc.
  874.  *
  875.  *----------------------------------------------------------------------
  876.  */
  877.  
  878. int
  879. Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
  880.     Tcl_Interp *interp;        /* Interpreter in which variable is
  881.                  * to be traced. */
  882.     char *part1;        /* Name of scalar variable or array. */
  883.     char *part2;        /* Name of element within array;  NULL means
  884.                  * trace applies to scalar variable or array
  885.                  * as-a-whole. */
  886.     int flags;            /* OR-ed collection of bits, including any
  887.                  * of TCL_TRACE_READS, TCL_TRACE_WRITES,
  888.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  889.     Tcl_VarTraceProc *proc;    /* Procedure to call when specified ops are
  890.                  * invoked upon varName. */
  891.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  892. {
  893.     Var *varPtr, *arrayPtr;
  894.     register VarTrace *tracePtr;
  895.  
  896.     varPtr = LookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG),
  897.         "trace", CRT_PART1|CRT_PART2, &arrayPtr);
  898.     if (varPtr == NULL) {
  899.     return TCL_ERROR;
  900.     }
  901.  
  902.     /*
  903.      * Set up trace information.
  904.      */
  905.  
  906.     tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
  907.     tracePtr->traceProc = proc;
  908.     tracePtr->clientData = clientData;
  909.     tracePtr->flags = flags &
  910.         (TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS);
  911.     tracePtr->nextPtr = varPtr->tracePtr;
  912.     varPtr->tracePtr = tracePtr;
  913.     return TCL_OK;
  914. }
  915.  
  916. /*
  917.  *----------------------------------------------------------------------
  918.  *
  919.  * Tcl_UntraceVar --
  920.  *
  921.  *    Remove a previously-created trace for a variable.
  922.  *
  923.  * Results:
  924.  *    None.
  925.  *
  926.  * Side effects:
  927.  *    If there exists a trace for the variable given by varName
  928.  *    with the given flags, proc, and clientData, then that trace
  929.  *    is removed.
  930.  *
  931.  *----------------------------------------------------------------------
  932.  */
  933.  
  934. void
  935. Tcl_UntraceVar(interp, varName, flags, proc, clientData)
  936.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  937.     char *varName;        /* Name of variable;  may end with "(index)"
  938.                  * to signify an array reference. */
  939.     int flags;            /* OR-ed collection of bits describing
  940.                  * current trace, including any of
  941.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  942.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  943.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  944.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  945. {
  946.     register char *p;
  947.  
  948.     /*
  949.      * If varName refers to an array (it ends with a parenthesized
  950.      * element name), then handle it specially.
  951.      */
  952.  
  953.     for (p = varName; *p != '\0'; p++) {
  954.     if (*p == '(') {
  955.         char *open = p;
  956.  
  957.         do {
  958.         p++;
  959.         } while (*p != '\0');
  960.         p--;
  961.         if (*p != ')') {
  962.         goto scalar;
  963.         }
  964.         *open = '\0';
  965.         *p = '\0';
  966.         Tcl_UntraceVar2(interp, varName, open+1, flags, proc, clientData);
  967.         *open = '(';
  968.         *p = ')';
  969.         return;
  970.     }
  971.     }
  972.  
  973.     scalar:
  974.     Tcl_UntraceVar2(interp, varName, (char *) NULL, flags, proc, clientData);
  975. }
  976.  
  977. /*
  978.  *----------------------------------------------------------------------
  979.  *
  980.  * Tcl_UntraceVar2 --
  981.  *
  982.  *    Remove a previously-created trace for a variable.
  983.  *
  984.  * Results:
  985.  *    None.
  986.  *
  987.  * Side effects:
  988.  *    If there exists a trace for the variable given by part1
  989.  *    and part2 with the given flags, proc, and clientData, then
  990.  *    that trace is removed.
  991.  *
  992.  *----------------------------------------------------------------------
  993.  */
  994.  
  995. void
  996. Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
  997.     Tcl_Interp *interp;        /* Interpreter containing traced variable. */
  998.     char *part1;        /* Name of variable or array. */
  999.     char *part2;        /* Name of element within array;  NULL means
  1000.                  * trace applies to scalar variable or array
  1001.                  * as-a-whole. */
  1002.     int flags;            /* OR-ed collection of bits describing
  1003.                  * current trace, including any of
  1004.                  * TCL_TRACE_READS, TCL_TRACE_WRITES,
  1005.                  * TCL_TRACE_UNSETS, and TCL_GLOBAL_ONLY. */
  1006.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1007.     ClientData clientData;    /* Arbitrary argument to pass to proc. */
  1008. {
  1009.     register VarTrace *tracePtr;
  1010.     VarTrace *prevPtr;
  1011.     Var *varPtr, *arrayPtr;
  1012.     Interp *iPtr = (Interp *) interp;
  1013.     ActiveVarTrace *activePtr;
  1014.  
  1015.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1016.         (char *) NULL, 0, &arrayPtr);
  1017.     if (varPtr == NULL) {
  1018.     return;
  1019.     }
  1020.  
  1021.     flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS);
  1022.     for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ;
  1023.         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
  1024.     if (tracePtr == NULL) {
  1025.         return;
  1026.     }
  1027.     if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
  1028.         && (tracePtr->clientData == clientData)) {
  1029.         break;
  1030.     }
  1031.     }
  1032.  
  1033.     /*
  1034.      * The code below makes it possible to delete traces while traces
  1035.      * are active:  it makes sure that the deleted trace won't be
  1036.      * processed by CallTraces.
  1037.      */
  1038.  
  1039.     for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  1040.         activePtr = activePtr->nextPtr) {
  1041.     if (activePtr->nextTracePtr == tracePtr) {
  1042.         activePtr->nextTracePtr = tracePtr->nextPtr;
  1043.     }
  1044.     }
  1045.     if (prevPtr == NULL) {
  1046.     varPtr->tracePtr = tracePtr->nextPtr;
  1047.     } else {
  1048.     prevPtr->nextPtr = tracePtr->nextPtr;
  1049.     }
  1050.     ckfree((char *) tracePtr);
  1051.  
  1052.     /*
  1053.      * If this is the last trace on the variable, and the variable is
  1054.      * unset and unused, then free up the variable.
  1055.      */
  1056.  
  1057.     if (varPtr->flags & VAR_UNDEFINED) {
  1058.     CleanupVar(varPtr, (Var *) NULL);
  1059.     }
  1060. }
  1061.  
  1062. /*
  1063.  *----------------------------------------------------------------------
  1064.  *
  1065.  * Tcl_VarTraceInfo --
  1066.  *
  1067.  *    Return the clientData value associated with a trace on a
  1068.  *    variable.  This procedure can also be used to step through
  1069.  *    all of the traces on a particular variable that have the
  1070.  *    same trace procedure.
  1071.  *
  1072.  * Results:
  1073.  *    The return value is the clientData value associated with
  1074.  *    a trace on the given variable.  Information will only be
  1075.  *    returned for a trace with proc as trace procedure.  If
  1076.  *    the clientData argument is NULL then the first such trace is
  1077.  *    returned;  otherwise, the next relevant one after the one
  1078.  *    given by clientData will be returned.  If the variable
  1079.  *    doesn't exist, or if there are no (more) traces for it,
  1080.  *    then NULL is returned.
  1081.  *
  1082.  * Side effects:
  1083.  *    None.
  1084.  *
  1085.  *----------------------------------------------------------------------
  1086.  */
  1087.  
  1088. ClientData
  1089. Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
  1090.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1091.     char *varName;        /* Name of variable;  may end with "(index)"
  1092.                  * to signify an array reference. */
  1093.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1094.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1095.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1096.                  * by this procedure, so this call will
  1097.                  * return the next trace after that one.
  1098.                  * If NULL, this call will return the
  1099.                  * first trace. */
  1100. {
  1101.     register char *p;
  1102.  
  1103.     /*
  1104.      * If varName refers to an array (it ends with a parenthesized
  1105.      * element name), then handle it specially.
  1106.      */
  1107.  
  1108.     for (p = varName; *p != '\0'; p++) {
  1109.     if (*p == '(') {
  1110.         ClientData result;
  1111.         char *open = p;
  1112.  
  1113.         do {
  1114.         p++;
  1115.         } while (*p != '\0');
  1116.         p--;
  1117.         if (*p != ')') {
  1118.         goto scalar;
  1119.         }
  1120.         *open = '\0';
  1121.         *p = '\0';
  1122.         result = Tcl_VarTraceInfo2(interp, varName, open+1, flags, proc,
  1123.         prevClientData);
  1124.         *open = '(';
  1125.         *p = ')';
  1126.         return result;
  1127.     }
  1128.     }
  1129.  
  1130.     scalar:
  1131.     return Tcl_VarTraceInfo2(interp, varName, (char *) NULL, flags, proc,
  1132.         prevClientData);
  1133. }
  1134.  
  1135. /*
  1136.  *----------------------------------------------------------------------
  1137.  *
  1138.  * Tcl_VarTraceInfo2 --
  1139.  *
  1140.  *    Same as Tcl_VarTraceInfo, except takes name in two pieces
  1141.  *    instead of one.
  1142.  *
  1143.  * Results:
  1144.  *    Same as Tcl_VarTraceInfo.
  1145.  *
  1146.  * Side effects:
  1147.  *    None.
  1148.  *
  1149.  *----------------------------------------------------------------------
  1150.  */
  1151.  
  1152. ClientData
  1153. Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
  1154.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1155.     char *part1;        /* Name of variable or array. */
  1156.     char *part2;        /* Name of element within array;  NULL means
  1157.                  * trace applies to scalar variable or array
  1158.                  * as-a-whole. */
  1159.     int flags;            /* 0 or TCL_GLOBAL_ONLY. */
  1160.     Tcl_VarTraceProc *proc;    /* Procedure assocated with trace. */
  1161.     ClientData prevClientData;    /* If non-NULL, gives last value returned
  1162.                  * by this procedure, so this call will
  1163.                  * return the next trace after that one.
  1164.                  * If NULL, this call will return the
  1165.                  * first trace. */
  1166. {
  1167.     register VarTrace *tracePtr;
  1168.     Var *varPtr, *arrayPtr;
  1169.  
  1170.     varPtr = LookupVar(interp, part1, part2, flags & TCL_GLOBAL_ONLY,
  1171.         (char *) NULL, 0, &arrayPtr);
  1172.     if (varPtr == NULL) {
  1173.     return NULL;
  1174.     }
  1175.  
  1176.     /*
  1177.      * Find the relevant trace, if any, and return its clientData.
  1178.      */
  1179.  
  1180.     tracePtr = varPtr->tracePtr;
  1181.     if (prevClientData != NULL) {
  1182.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1183.         if ((tracePtr->clientData == prevClientData)
  1184.             && (tracePtr->traceProc == proc)) {
  1185.         tracePtr = tracePtr->nextPtr;
  1186.         break;
  1187.         }
  1188.     }
  1189.     }
  1190.     for ( ; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
  1191.     if (tracePtr->traceProc == proc) {
  1192.         return tracePtr->clientData;
  1193.     }
  1194.     }
  1195.     return NULL;
  1196. }
  1197.  
  1198. /*
  1199.  *----------------------------------------------------------------------
  1200.  *
  1201.  * Tcl_SetCmd --
  1202.  *
  1203.  *    This procedure is invoked to process the "set" Tcl command.
  1204.  *    See the user documentation for details on what it does.
  1205.  *
  1206.  * Results:
  1207.  *    A standard Tcl result value.
  1208.  *
  1209.  * Side effects:
  1210.  *    A variable's value may be changed.
  1211.  *
  1212.  *----------------------------------------------------------------------
  1213.  */
  1214.  
  1215.     /* ARGSUSED */
  1216. int
  1217. Tcl_SetCmd(dummy, interp, argc, argv)
  1218.     ClientData dummy;            /* Not used. */
  1219.     register Tcl_Interp *interp;    /* Current interpreter. */
  1220.     int argc;                /* Number of arguments. */
  1221.     char **argv;            /* Argument strings. */
  1222. {
  1223.     if (argc == 2) {
  1224.     char *value;
  1225.  
  1226.     value = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  1227.     if (value == NULL) {
  1228.         return TCL_ERROR;
  1229.     }
  1230.     interp->result = value;
  1231.     return TCL_OK;
  1232.     } else if (argc == 3) {
  1233.     char *result;
  1234.  
  1235.     result = Tcl_SetVar(interp, argv[1], argv[2], TCL_LEAVE_ERR_MSG);
  1236.     if (result == NULL) {
  1237.         return TCL_ERROR;
  1238.     }
  1239.     interp->result = result;
  1240.     return TCL_OK;
  1241.     } else {
  1242.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1243.         argv[0], " varName ?newValue?\"", (char *) NULL);
  1244.     return TCL_ERROR;
  1245.     }
  1246. }
  1247.  
  1248. /*
  1249.  *----------------------------------------------------------------------
  1250.  *
  1251.  * Tcl_UnsetCmd --
  1252.  *
  1253.  *    This procedure is invoked to process the "unset" Tcl command.
  1254.  *    See the user documentation for details on what it does.
  1255.  *
  1256.  * Results:
  1257.  *    A standard Tcl result value.
  1258.  *
  1259.  * Side effects:
  1260.  *    See the user documentation.
  1261.  *
  1262.  *----------------------------------------------------------------------
  1263.  */
  1264.  
  1265.     /* ARGSUSED */
  1266. int
  1267. Tcl_UnsetCmd(dummy, interp, argc, argv)
  1268.     ClientData dummy;            /* Not used. */
  1269.     register Tcl_Interp *interp;    /* Current interpreter. */
  1270.     int argc;                /* Number of arguments. */
  1271.     char **argv;            /* Argument strings. */
  1272. {
  1273.     int i;
  1274.  
  1275.     if (argc < 2) {
  1276.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1277.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1278.     return TCL_ERROR;
  1279.     }
  1280.     for (i = 1; i < argc; i++) {
  1281.     if (Tcl_UnsetVar(interp, argv[i], TCL_LEAVE_ERR_MSG) != TCL_OK) {
  1282.         return TCL_ERROR;
  1283.     }
  1284.     }
  1285.     return TCL_OK;
  1286. }
  1287.  
  1288. /*
  1289.  *----------------------------------------------------------------------
  1290.  *
  1291.  * Tcl_AppendCmd --
  1292.  *
  1293.  *    This procedure is invoked to process the "append" Tcl command.
  1294.  *    See the user documentation for details on what it does.
  1295.  *
  1296.  * Results:
  1297.  *    A standard Tcl result value.
  1298.  *
  1299.  * Side effects:
  1300.  *    A variable's value may be changed.
  1301.  *
  1302.  *----------------------------------------------------------------------
  1303.  */
  1304.  
  1305.     /* ARGSUSED */
  1306. int
  1307. Tcl_AppendCmd(dummy, interp, argc, argv)
  1308.     ClientData dummy;            /* Not used. */
  1309.     register Tcl_Interp *interp;    /* Current interpreter. */
  1310.     int argc;                /* Number of arguments. */
  1311.     char **argv;            /* Argument strings. */
  1312. {
  1313.     int i;
  1314.     char *result = NULL;        /* (Initialization only needed to keep
  1315.                      * the compiler from complaining) */
  1316.  
  1317.     if (argc < 3) {
  1318.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1319.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1320.     return TCL_ERROR;
  1321.     }
  1322.  
  1323.     for (i = 2; i < argc; i++) {
  1324.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1325.         TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
  1326.     if (result == NULL) {
  1327.         return TCL_ERROR;
  1328.     }
  1329.     }
  1330.     interp->result = result;
  1331.     return TCL_OK;
  1332. }
  1333.  
  1334. /*
  1335.  *----------------------------------------------------------------------
  1336.  *
  1337.  * Tcl_LappendCmd --
  1338.  *
  1339.  *    This procedure is invoked to process the "lappend" Tcl command.
  1340.  *    See the user documentation for details on what it does.
  1341.  *
  1342.  * Results:
  1343.  *    A standard Tcl result value.
  1344.  *
  1345.  * Side effects:
  1346.  *    A variable's value may be changed.
  1347.  *
  1348.  *----------------------------------------------------------------------
  1349.  */
  1350.  
  1351.     /* ARGSUSED */
  1352. int
  1353. Tcl_LappendCmd(dummy, interp, argc, argv)
  1354.     ClientData dummy;            /* Not used. */
  1355.     register Tcl_Interp *interp;    /* Current interpreter. */
  1356.     int argc;                /* Number of arguments. */
  1357.     char **argv;            /* Argument strings. */
  1358. {
  1359.     int i;
  1360.     char *result = NULL;        /* (Initialization only needed to keep
  1361.                      * the compiler from complaining) */
  1362.  
  1363.     if (argc < 3) {
  1364.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1365.         argv[0], " varName value ?value ...?\"", (char *) NULL);
  1366.     return TCL_ERROR;
  1367.     }
  1368.  
  1369.     for (i = 2; i < argc; i++) {
  1370.     result = Tcl_SetVar(interp, argv[1], argv[i],
  1371.         TCL_APPEND_VALUE|TCL_LIST_ELEMENT|TCL_LEAVE_ERR_MSG);
  1372.     if (result == NULL) {
  1373.         return TCL_ERROR;
  1374.     }
  1375.     }
  1376.     interp->result = result;
  1377.     return TCL_OK;
  1378. }
  1379.  
  1380. /*
  1381.  *----------------------------------------------------------------------
  1382.  *
  1383.  * Tcl_ArrayCmd --
  1384.  *
  1385.  *    This procedure is invoked to process the "array" Tcl command.
  1386.  *    See the user documentation for details on what it does.
  1387.  *
  1388.  * Results:
  1389.  *    A standard Tcl result value.
  1390.  *
  1391.  * Side effects:
  1392.  *    See the user documentation.
  1393.  *
  1394.  *----------------------------------------------------------------------
  1395.  */
  1396.  
  1397.     /* ARGSUSED */
  1398. int
  1399. Tcl_ArrayCmd(dummy, interp, argc, argv)
  1400.     ClientData dummy;            /* Not used. */
  1401.     register Tcl_Interp *interp;    /* Current interpreter. */
  1402.     int argc;                /* Number of arguments. */
  1403.     char **argv;            /* Argument strings. */
  1404. {
  1405.     int length;
  1406.     char c;
  1407.     Var *varPtr;
  1408.     Tcl_HashEntry *hPtr;
  1409.     Interp *iPtr = (Interp *) interp;
  1410.  
  1411.     if (argc < 3) {
  1412.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1413.         argv[0], " option arrayName ?arg ...?\"", (char *) NULL);
  1414.     return TCL_ERROR;
  1415.     }
  1416.  
  1417.     /*
  1418.      * Locate the array variable (and it better be an array).
  1419.      */
  1420.  
  1421.     if (iPtr->varFramePtr == NULL) {
  1422.     hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  1423.     } else {
  1424.     hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  1425.     }
  1426.     if (hPtr == NULL) {
  1427.     notArray:
  1428.     Tcl_AppendResult(interp, "\"", argv[2], "\" isn't an array",
  1429.         (char *) NULL);
  1430.     return TCL_ERROR;
  1431.     }
  1432.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1433.     if (varPtr->flags & VAR_UPVAR) {
  1434.     varPtr = varPtr->value.upvarPtr;
  1435.     }
  1436.     if (!(varPtr->flags & VAR_ARRAY)) {
  1437.     goto notArray;
  1438.     }
  1439.  
  1440.     /*
  1441.      * Dispatch based on the option.
  1442.      */
  1443.  
  1444.     c = argv[1][0];
  1445.     length = strlen(argv[1]);
  1446.     if ((c == 'a') && (strncmp(argv[1], "anymore", length) == 0)) {
  1447.     ArraySearch *searchPtr;
  1448.  
  1449.     if (argc != 4) {
  1450.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1451.             argv[0], " anymore arrayName searchId\"", (char *) NULL);
  1452.         return TCL_ERROR;
  1453.     }
  1454.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1455.     if (searchPtr == NULL) {
  1456.         return TCL_ERROR;
  1457.     }
  1458.     while (1) {
  1459.         Var *varPtr2;
  1460.  
  1461.         if (searchPtr->nextEntry != NULL) {
  1462.         varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
  1463.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1464.             break;
  1465.         }
  1466.         }
  1467.         searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
  1468.         if (searchPtr->nextEntry == NULL) {
  1469.         interp->result = "0";
  1470.         return TCL_OK;
  1471.         }
  1472.     }
  1473.     interp->result = "1";
  1474.     return TCL_OK;
  1475.     } else if ((c == 'd') && (strncmp(argv[1], "donesearch", length) == 0)) {
  1476.     ArraySearch *searchPtr, *prevPtr;
  1477.  
  1478.     if (argc != 4) {
  1479.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1480.             argv[0], " donesearch arrayName searchId\"", (char *) NULL);
  1481.         return TCL_ERROR;
  1482.     }
  1483.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1484.     if (searchPtr == NULL) {
  1485.         return TCL_ERROR;
  1486.     }
  1487.     if (varPtr->searchPtr == searchPtr) {
  1488.         varPtr->searchPtr = searchPtr->nextPtr;
  1489.     } else {
  1490.         for (prevPtr = varPtr->searchPtr; ; prevPtr = prevPtr->nextPtr) {
  1491.         if (prevPtr->nextPtr == searchPtr) {
  1492.             prevPtr->nextPtr = searchPtr->nextPtr;
  1493.             break;
  1494.         }
  1495.         }
  1496.     }
  1497.     ckfree((char *) searchPtr);
  1498.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)
  1499.         && (length >= 2)) {
  1500.     Tcl_HashSearch search;
  1501.     Var *varPtr2;
  1502.  
  1503.     if (argc != 3) {
  1504.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1505.             argv[0], " names arrayName\"", (char *) NULL);
  1506.         return TCL_ERROR;
  1507.     }
  1508.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1509.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1510.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1511.         if (varPtr2->flags & VAR_UNDEFINED) {
  1512.         continue;
  1513.         }
  1514.         Tcl_AppendElement(interp,
  1515.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr));
  1516.     }
  1517.     } else if ((c == 'n') && (strncmp(argv[1], "nextelement", length) == 0)
  1518.         && (length >= 2)) {
  1519.     ArraySearch *searchPtr;
  1520.     Tcl_HashEntry *hPtr;
  1521.  
  1522.     if (argc != 4) {
  1523.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1524.             argv[0], " nextelement arrayName searchId\"",
  1525.             (char *) NULL);
  1526.         return TCL_ERROR;
  1527.     }
  1528.     searchPtr = ParseSearchId(interp, varPtr, argv[2], argv[3]);
  1529.     if (searchPtr == NULL) {
  1530.         return TCL_ERROR;
  1531.     }
  1532.     while (1) {
  1533.         Var *varPtr2;
  1534.  
  1535.         hPtr = searchPtr->nextEntry;
  1536.         if (hPtr == NULL) {
  1537.         hPtr = Tcl_NextHashEntry(&searchPtr->search);
  1538.         if (hPtr == NULL) {
  1539.             return TCL_OK;
  1540.         }
  1541.         } else {
  1542.         searchPtr->nextEntry = NULL;
  1543.         }
  1544.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1545.         if (!(varPtr2->flags & VAR_UNDEFINED)) {
  1546.         break;
  1547.         }
  1548.     }
  1549.     interp->result = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
  1550.     } else if ((c == 's') && (strncmp(argv[1], "size", length) == 0)
  1551.         && (length >= 2)) {
  1552.     Tcl_HashSearch search;
  1553.     Var *varPtr2;
  1554.     int size;
  1555.  
  1556.     if (argc != 3) {
  1557.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1558.             argv[0], " size arrayName\"", (char *) NULL);
  1559.         return TCL_ERROR;
  1560.     }
  1561.     size = 0;
  1562.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  1563.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  1564.         varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
  1565.         if (varPtr2->flags & VAR_UNDEFINED) {
  1566.         continue;
  1567.         }
  1568.         size++;
  1569.     }
  1570.     sprintf(interp->result, "%d", size);
  1571.     } else if ((c == 's') && (strncmp(argv[1], "startsearch", length) == 0)
  1572.         && (length >= 2)) {
  1573.     ArraySearch *searchPtr;
  1574.  
  1575.     if (argc != 3) {
  1576.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1577.             argv[0], " startsearch arrayName\"", (char *) NULL);
  1578.         return TCL_ERROR;
  1579.     }
  1580.     searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
  1581.     if (varPtr->searchPtr == NULL) {
  1582.         searchPtr->id = 1;
  1583.         Tcl_AppendResult(interp, "s-1-", argv[2], (char *) NULL);
  1584.     } else {
  1585.         char string[20];
  1586.  
  1587.         searchPtr->id = varPtr->searchPtr->id + 1;
  1588.         sprintf(string, "%d", searchPtr->id);
  1589.         Tcl_AppendResult(interp, "s-", string, "-", argv[2],
  1590.             (char *) NULL);
  1591.     }
  1592.     searchPtr->varPtr = varPtr;
  1593.     searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr,
  1594.         &searchPtr->search);
  1595.     searchPtr->nextPtr = varPtr->searchPtr;
  1596.     varPtr->searchPtr = searchPtr;
  1597.     } else {
  1598.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1599.         "\": should be anymore, donesearch, names, nextelement, ",
  1600.         "size, or startsearch", (char *) NULL);
  1601.     return TCL_ERROR;
  1602.     }
  1603.     return TCL_OK;
  1604. }
  1605.  
  1606. /*
  1607.  *----------------------------------------------------------------------
  1608.  *
  1609.  * MakeUpvar --
  1610.  *
  1611.  *    This procedure does all of the work of the "global" and "upvar"
  1612.  *    commands.
  1613.  *
  1614.  * Results:
  1615.  *    A standard Tcl completion code.  If an error occurs then an
  1616.  *    error message is left in iPtr->result.
  1617.  *
  1618.  * Side effects:
  1619.  *    The variable given by myName is linked to the variable in
  1620.  *    framePtr given by otherP1 and otherP2, so that references to
  1621.  *    myName are redirected to the other variable like a symbolic
  1622. *    link.
  1623.  *
  1624.  *----------------------------------------------------------------------
  1625.  */
  1626.  
  1627. static int
  1628. MakeUpvar(iPtr, framePtr, otherP1, otherP2, myName)
  1629.     Interp *iPtr;        /* Interpreter containing variables.  Used
  1630.                  * for error messages, too. */
  1631.     CallFrame *framePtr;    /* Call frame containing "other" variable.
  1632.                  * NULL means use global context. */
  1633.     char *otherP1, *otherP2;    /* Two-part name of variable in framePtr. */
  1634.     char *myName;        /* Name of variable in local table, which
  1635.                  * will refer to otherP1/P2.  Must be a
  1636.                  * scalar. */
  1637. {
  1638.     Tcl_HashEntry *hPtr;
  1639.     Var *otherPtr, *varPtr, *arrayPtr;
  1640.     CallFrame *savedFramePtr;
  1641.     int new;
  1642.  
  1643.     /*
  1644.      * In order to use LookupVar to find "other", temporarily replace
  1645.      * the current frame pointer in the interpreter.
  1646.      */
  1647.  
  1648.     savedFramePtr = iPtr->varFramePtr;
  1649.     iPtr->varFramePtr = framePtr;
  1650.     otherPtr = LookupVar((Tcl_Interp *) iPtr, otherP1, otherP2,
  1651.         TCL_LEAVE_ERR_MSG, "access", CRT_PART1|CRT_PART2, &arrayPtr);
  1652.     iPtr->varFramePtr = savedFramePtr;
  1653.     if (otherPtr == NULL) {
  1654.     return TCL_ERROR;
  1655.     }
  1656.     if (iPtr->varFramePtr != NULL) {
  1657.     hPtr = Tcl_CreateHashEntry(&iPtr->varFramePtr->varTable, myName, &new);
  1658.     } else {
  1659.     hPtr = Tcl_CreateHashEntry(&iPtr->globalTable, myName, &new);
  1660.     }
  1661.     if (new) {
  1662.     varPtr = NewVar();
  1663.     Tcl_SetHashValue(hPtr, varPtr);
  1664.     varPtr->hPtr = hPtr;
  1665.     } else {
  1666.     /*
  1667.      * The variable already exists.  If it's not an upvar then it's
  1668.      * an error.  If it is an upvar, then just disconnect it from the
  1669.      * thing it currently refers to.
  1670.      */
  1671.  
  1672.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  1673.     if (varPtr->flags & VAR_UPVAR) {
  1674.         Var *upvarPtr;
  1675.  
  1676.         upvarPtr = varPtr->value.upvarPtr;
  1677.         if (upvarPtr == otherPtr) {
  1678.         return TCL_OK;
  1679.         }
  1680.         upvarPtr->refCount--;
  1681.         if (upvarPtr->flags & VAR_UNDEFINED) {
  1682.         CleanupVar(upvarPtr, (Var *) NULL);
  1683.         }
  1684.     } else if (!(varPtr->flags & VAR_UNDEFINED)) {
  1685.         Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
  1686.         "\" already exists", (char *) NULL);
  1687.         return TCL_ERROR;
  1688.     }
  1689.     }
  1690.     varPtr->flags = (varPtr->flags & ~VAR_UNDEFINED) | VAR_UPVAR;
  1691.     varPtr->value.upvarPtr = otherPtr;
  1692.     otherPtr->refCount++;
  1693.     return TCL_OK;
  1694. }
  1695.  
  1696. /*
  1697.  *----------------------------------------------------------------------
  1698.  *
  1699.  * Tcl_GlobalCmd --
  1700.  *
  1701.  *    This procedure is invoked to process the "global" Tcl command.
  1702.  *    See the user documentation for details on what it does.
  1703.  *
  1704.  * Results:
  1705.  *    A standard Tcl result value.
  1706.  *
  1707.  * Side effects:
  1708.  *    See the user documentation.
  1709.  *
  1710.  *----------------------------------------------------------------------
  1711.  */
  1712.  
  1713.     /* ARGSUSED */
  1714. int
  1715. Tcl_GlobalCmd(dummy, interp, argc, argv)
  1716.     ClientData dummy;            /* Not used. */
  1717.     Tcl_Interp *interp;            /* Current interpreter. */
  1718.     int argc;                /* Number of arguments. */
  1719.     char **argv;            /* Argument strings. */
  1720. {
  1721.     register Interp *iPtr = (Interp *) interp;
  1722.  
  1723.     if (argc < 2) {
  1724.     Tcl_AppendResult((Tcl_Interp *) iPtr, "wrong # args: should be \"",
  1725.         argv[0], " varName ?varName ...?\"", (char *) NULL);
  1726.     return TCL_ERROR;
  1727.     }
  1728.     if (iPtr->varFramePtr == NULL) {
  1729.     return TCL_OK;
  1730.     }
  1731.  
  1732.     for (argc--, argv++; argc > 0; argc--, argv++) {
  1733.     if (MakeUpvar(iPtr, (CallFrame *) NULL, *argv, (char *) NULL, *argv)
  1734.         != TCL_OK) {
  1735.         return TCL_ERROR;
  1736.     }
  1737.     }
  1738.     return TCL_OK;
  1739. }
  1740.  
  1741. /*
  1742.  *----------------------------------------------------------------------
  1743.  *
  1744.  * Tcl_UpvarCmd --
  1745.  *
  1746.  *    This procedure is invoked to process the "upvar" Tcl command.
  1747.  *    See the user documentation for details on what it does.
  1748.  *
  1749.  * Results:
  1750.  *    A standard Tcl result value.
  1751.  *
  1752.  * Side effects:
  1753.  *    See the user documentation.
  1754.  *
  1755.  *----------------------------------------------------------------------
  1756.  */
  1757.  
  1758.     /* ARGSUSED */
  1759. int
  1760. Tcl_UpvarCmd(dummy, interp, argc, argv)
  1761.     ClientData dummy;            /* Not used. */
  1762.     Tcl_Interp *interp;            /* Current interpreter. */
  1763.     int argc;                /* Number of arguments. */
  1764.     char **argv;            /* Argument strings. */
  1765. {
  1766.     register Interp *iPtr = (Interp *) interp;
  1767.     int result;
  1768.     CallFrame *framePtr;
  1769.     register char *p;
  1770.  
  1771.     if (argc < 3) {
  1772.     upvarSyntax:
  1773.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1774.         " ?level? otherVar localVar ?otherVar localVar ...?\"",
  1775.         (char *) NULL);
  1776.     return TCL_ERROR;
  1777.     }
  1778.  
  1779.     /*
  1780.      * Find the hash table containing the variable being referenced.
  1781.      */
  1782.  
  1783.     result = TclGetFrame(interp, argv[1], &framePtr);
  1784.     if (result == -1) {
  1785.     return TCL_ERROR;
  1786.     }
  1787.     argc -= result+1;
  1788.     if ((argc & 1) != 0) {
  1789.     goto upvarSyntax;
  1790.     }
  1791.     argv += result+1;
  1792.  
  1793.     /*
  1794.      * Iterate over all the pairs of (other variable, local variable)
  1795.      * names.  For each pair, divide the other variable name into two
  1796.      * parts, then call MakeUpvar to do all the work of creating linking
  1797.      * it to the local variable.
  1798.      */
  1799.  
  1800.     for ( ; argc > 0; argc -= 2, argv += 2) {
  1801.     for (p = argv[0]; *p != 0; p++) {
  1802.         if (*p == '(') {
  1803.         char *open = p;
  1804.  
  1805.         do {
  1806.             p++;
  1807.         } while (*p != '\0');
  1808.         p--;
  1809.         if (*p != ')') {
  1810.             goto scalar;
  1811.         }
  1812.         *open = '\0';
  1813.         *p = '\0';
  1814.         result = MakeUpvar(iPtr, framePtr, argv[0], open+1, argv[1]);
  1815.         *open = '(';
  1816.         *p = ')';
  1817.         goto checkResult;
  1818.         }
  1819.     }
  1820.     scalar:
  1821.     result = MakeUpvar(iPtr, framePtr, argv[0], (char *) NULL, argv[1]);
  1822.  
  1823.     checkResult:
  1824.     if (result != TCL_OK) {
  1825.         return TCL_ERROR;
  1826.     }
  1827.     }
  1828.     return TCL_OK;
  1829. }
  1830.  
  1831. /*
  1832.  *----------------------------------------------------------------------
  1833.  *
  1834.  * CallTraces --
  1835.  *
  1836.  *    This procedure is invoked to find and invoke relevant
  1837.  *    trace procedures associated with a particular operation on
  1838.  *    a variable.  This procedure invokes traces both on the
  1839.  *    variable and on its containing array (where relevant).
  1840.  *
  1841.  * Results:
  1842.  *    The return value is NULL if no trace procedures were invoked, or
  1843.  *    if all the invoked trace procedures returned successfully.
  1844.  *    The return value is non-zero if a trace procedure returned an
  1845.  *    error (in this case no more trace procedures were invoked after
  1846.  *    the error was returned).  In this case the return value is a
  1847.  *    pointer to a static string describing the error.
  1848.  *
  1849.  * Side effects:
  1850.  *    Almost anything can happen, depending on trace;  this procedure
  1851.  *    itself doesn't have any side effects.
  1852.  *
  1853.  *----------------------------------------------------------------------
  1854.  */
  1855.  
  1856. static char *
  1857. CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags)
  1858.     Interp *iPtr;            /* Interpreter containing variable. */
  1859.     register Var *arrayPtr;        /* Pointer to array variable that
  1860.                      * contains the variable, or NULL if
  1861.                      * the variable isn't an element of an
  1862.                      * array. */
  1863.     Var *varPtr;            /* Variable whose traces are to be
  1864.                      * invoked. */
  1865.     char *part1, *part2;        /* Variable's two-part name. */
  1866.     int flags;                /* Flags to pass to trace procedures:
  1867.                      * indicates what's happening to
  1868.                      * variable, plus other stuff like
  1869.                      * TCL_GLOBAL_ONLY and
  1870.                      * TCL_INTERP_DESTROYED. */
  1871. {
  1872.     register VarTrace *tracePtr;
  1873.     ActiveVarTrace active;
  1874.     char *result;
  1875.  
  1876.     /*
  1877.      * If there are already similar trace procedures active for the
  1878.      * variable, don't call them again.
  1879.      */
  1880.  
  1881.     if (varPtr->flags & VAR_TRACE_ACTIVE) {
  1882.     return NULL;
  1883.     }
  1884.     varPtr->flags |= VAR_TRACE_ACTIVE;
  1885.     varPtr->refCount++;
  1886.  
  1887.     /*
  1888.      * Invoke traces on the array containing the variable, if relevant.
  1889.      */
  1890.  
  1891.     result = NULL;
  1892.     active.nextPtr = iPtr->activeTracePtr;
  1893.     iPtr->activeTracePtr = &active;
  1894.     if (arrayPtr != NULL) {
  1895.     arrayPtr->refCount++;
  1896.     active.varPtr = arrayPtr;
  1897.     for (tracePtr = arrayPtr->tracePtr;  tracePtr != NULL;
  1898.         tracePtr = active.nextTracePtr) {
  1899.         active.nextTracePtr = tracePtr->nextPtr;
  1900.         if (!(tracePtr->flags & flags)) {
  1901.         continue;
  1902.         }
  1903.         result = (*tracePtr->traceProc)(tracePtr->clientData,
  1904.             (Tcl_Interp *) iPtr, part1, part2, flags);
  1905.         if (result != NULL) {
  1906.         if (flags & TCL_TRACE_UNSETS) {
  1907.             result = NULL;
  1908.         } else {
  1909.             goto done;
  1910.         }
  1911.         }
  1912.     }
  1913.     }
  1914.  
  1915.     /*
  1916.      * Invoke traces on the variable itself.
  1917.      */
  1918.  
  1919.     if (flags & TCL_TRACE_UNSETS) {
  1920.     flags |= TCL_TRACE_DESTROYED;
  1921.     }
  1922.     active.varPtr = varPtr;
  1923.     for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
  1924.         tracePtr = active.nextTracePtr) {
  1925.     active.nextTracePtr = tracePtr->nextPtr;
  1926.     if (!(tracePtr->flags & flags)) {
  1927.         continue;
  1928.     }
  1929.     result = (*tracePtr->traceProc)(tracePtr->clientData,
  1930.         (Tcl_Interp *) iPtr, part1, part2, flags);
  1931.     if (result != NULL) {
  1932.         if (flags & TCL_TRACE_UNSETS) {
  1933.         result = NULL;
  1934.         } else {
  1935.         goto done;
  1936.         }
  1937.     }
  1938.     }
  1939.  
  1940.     /*
  1941.      * Restore the variable's flags, remove the record of our active
  1942.      * traces, and then return.
  1943.      */
  1944.  
  1945.     done:
  1946.     if (arrayPtr != NULL) {
  1947.     arrayPtr->refCount--;
  1948.     }
  1949.     varPtr->flags &= ~VAR_TRACE_ACTIVE;
  1950.     varPtr->refCount--;
  1951.     iPtr->activeTracePtr = active.nextPtr;
  1952.     return result;
  1953. }
  1954.  
  1955. /*
  1956.  *----------------------------------------------------------------------
  1957.  *
  1958.  * NewVar --
  1959.  *
  1960.  *    Create a new variable with a given amount of storage
  1961.  *    space.
  1962.  *
  1963.  * Results:
  1964.  *    The return value is a pointer to the new variable structure.
  1965.  *    The variable will not be part of any hash table yet.  Its
  1966.  *    initial value is empty.
  1967.  *
  1968.  * Side effects:
  1969.  *    Storage gets allocated.
  1970.  *
  1971.  *----------------------------------------------------------------------
  1972.  */
  1973.  
  1974. static Var *
  1975. NewVar()
  1976. {
  1977.     register Var *varPtr;
  1978.  
  1979.     varPtr = (Var *) ckalloc(sizeof(Var));
  1980.     varPtr->valueLength = 0;
  1981.     varPtr->valueSpace = 0;
  1982.     varPtr->value.string = NULL;
  1983.     varPtr->hPtr = NULL;
  1984.     varPtr->refCount = 0;
  1985.     varPtr->tracePtr = NULL;
  1986.     varPtr->searchPtr = NULL;
  1987.     varPtr->flags = VAR_UNDEFINED;
  1988.     return varPtr;
  1989. }
  1990.  
  1991. /*
  1992.  *----------------------------------------------------------------------
  1993.  *
  1994.  * ParseSearchId --
  1995.  *
  1996.  *    This procedure translates from a string to a pointer to an
  1997.  *    active array search (if there is one that matches the string).
  1998.  *
  1999.  * Results:
  2000.  *    The return value is a pointer to the array search indicated
  2001.  *    by string, or NULL if there isn't one.  If NULL is returned,
  2002.  *    interp->result contains an error message.
  2003.  *
  2004.  * Side effects:
  2005.  *    None.
  2006.  *
  2007.  *----------------------------------------------------------------------
  2008.  */
  2009.  
  2010. static ArraySearch *
  2011. ParseSearchId(interp, varPtr, varName, string)
  2012.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2013.     Var *varPtr;        /* Array variable search is for. */
  2014.     char *varName;        /* Name of array variable that search is
  2015.                  * supposed to be for. */
  2016.     char *string;        /* String containing id of search.  Must have
  2017.                  * form "search-num-var" where "num" is a
  2018.                  * decimal number and "var" is a variable
  2019.                  * name. */
  2020. {
  2021.     char *end;
  2022.     int id;
  2023.     ArraySearch *searchPtr;
  2024.  
  2025.     /*
  2026.      * Parse the id into the three parts separated by dashes.
  2027.      */
  2028.  
  2029.     if ((string[0] != 's') || (string[1] != '-')) {
  2030.     syntax:
  2031.     Tcl_AppendResult(interp, "illegal search identifier \"", string,
  2032.         "\"", (char *) NULL);
  2033.     return NULL;
  2034.     }
  2035.     id = strtoul(string+2, &end, 10);
  2036.     if ((end == (string+2)) || (*end != '-')) {
  2037.     goto syntax;
  2038.     }
  2039.     if (strcmp(end+1, varName) != 0) {
  2040.     Tcl_AppendResult(interp, "search identifier \"", string,
  2041.         "\" isn't for variable \"", varName, "\"", (char *) NULL);
  2042.     return NULL;
  2043.     }
  2044.  
  2045.     /*
  2046.      * Search through the list of active searches on the interpreter
  2047.      * to see if the desired one exists.
  2048.      */
  2049.  
  2050.     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;
  2051.         searchPtr = searchPtr->nextPtr) {
  2052.     if (searchPtr->id == id) {
  2053.         return searchPtr;
  2054.     }
  2055.     }
  2056.     Tcl_AppendResult(interp, "couldn't find search \"", string, "\"",
  2057.         (char *) NULL);
  2058.     return NULL;
  2059. }
  2060.  
  2061. /*
  2062.  *----------------------------------------------------------------------
  2063.  *
  2064.  * DeleteSearches --
  2065.  *
  2066.  *    This procedure is called to free up all of the searches
  2067.  *    associated with an array variable.
  2068.  *
  2069.  * Results:
  2070.  *    None.
  2071.  *
  2072.  * Side effects:
  2073.  *    Memory is released to the storage allocator.
  2074.  *
  2075.  *----------------------------------------------------------------------
  2076.  */
  2077.  
  2078. static void
  2079. DeleteSearches(arrayVarPtr)
  2080.     register Var *arrayVarPtr;        /* Variable whose searches are
  2081.                      * to be deleted. */
  2082. {
  2083.     ArraySearch *searchPtr;
  2084.  
  2085.     while (arrayVarPtr->searchPtr != NULL) {
  2086.     searchPtr = arrayVarPtr->searchPtr;
  2087.     arrayVarPtr->searchPtr = searchPtr->nextPtr;
  2088.     ckfree((char *) searchPtr);
  2089.     }
  2090. }
  2091.  
  2092. /*
  2093.  *----------------------------------------------------------------------
  2094.  *
  2095.  * TclDeleteVars --
  2096.  *
  2097.  *    This procedure is called to recycle all the storage space
  2098.  *    associated with a table of variables.  For this procedure
  2099.  *    to work correctly, it must not be possible for any of the
  2100.  *    variable in the table to be accessed from Tcl commands
  2101.  *    (e.g. from trace procedures).
  2102.  *
  2103.  * Results:
  2104.  *    None.
  2105.  *
  2106.  * Side effects:
  2107.  *    Variables are deleted and trace procedures are invoked, if
  2108.  *    any are declared.
  2109.  *
  2110.  *----------------------------------------------------------------------
  2111.  */
  2112.  
  2113. void
  2114. TclDeleteVars(iPtr, tablePtr)
  2115.     Interp *iPtr;        /* Interpreter to which variables belong. */
  2116.     Tcl_HashTable *tablePtr;    /* Hash table containing variables to
  2117.                  * delete. */
  2118. {
  2119.     Tcl_HashSearch search;
  2120.     Tcl_HashEntry *hPtr;
  2121.     register Var *varPtr;
  2122.     Var *upvarPtr;
  2123.     int flags;
  2124.     ActiveVarTrace *activePtr;
  2125.  
  2126.     flags = TCL_TRACE_UNSETS;
  2127.     if (tablePtr == &iPtr->globalTable) {
  2128.     flags |= TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY;
  2129.     }
  2130.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
  2131.         hPtr = Tcl_NextHashEntry(&search)) {
  2132.     varPtr = (Var *) Tcl_GetHashValue(hPtr);
  2133.  
  2134.     /*
  2135.      * For global/upvar variables referenced in procedures, decrement
  2136.      * the reference count on the variable referred to, and free up
  2137.      * the referenced variable if it's no longer needed.
  2138.      */
  2139.  
  2140.     if (varPtr->flags & VAR_UPVAR) {
  2141.         upvarPtr = varPtr->value.upvarPtr;
  2142.         upvarPtr->refCount--;
  2143.         if (upvarPtr->flags & VAR_UNDEFINED) {
  2144.         CleanupVar(upvarPtr, (Var *) NULL);
  2145.         }
  2146.     }
  2147.  
  2148.     /*
  2149.      * Invoke traces on the variable that is being deleted, then
  2150.      * free up the variable's space (no need to free the hash entry
  2151.      * here, unless we're dealing with a global variable:  the
  2152.      * hash entries will be deleted automatically when the whole
  2153.      * table is deleted).
  2154.      */
  2155.  
  2156.     if (varPtr->tracePtr != NULL) {
  2157.         (void) CallTraces(iPtr, (Var *) NULL, varPtr,
  2158.             Tcl_GetHashKey(tablePtr, hPtr), (char *) NULL, flags);
  2159.         while (varPtr->tracePtr != NULL) {
  2160.         VarTrace *tracePtr = varPtr->tracePtr;
  2161.         varPtr->tracePtr = tracePtr->nextPtr;
  2162.         ckfree((char *) tracePtr);
  2163.         }
  2164.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2165.             activePtr = activePtr->nextPtr) {
  2166.         if (activePtr->varPtr == varPtr) {
  2167.             activePtr->nextTracePtr = NULL;
  2168.         }
  2169.         }
  2170.     }
  2171.     if (varPtr->flags & VAR_ARRAY) {
  2172.         DeleteArray(iPtr, Tcl_GetHashKey(tablePtr, hPtr), varPtr, flags);
  2173.     }
  2174.     if (varPtr->valueSpace > 0) {
  2175.         /*
  2176.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2177.          * currently points to this variable (for example, a "set" or
  2178.          * "lappend" command was the last command in a procedure that's
  2179.          * being returned from).  If this is the case, then just pass
  2180.          * ownership of the value string to the Tcl interpreter.
  2181.          */
  2182.  
  2183.         if (iPtr->result == varPtr->value.string) {
  2184.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2185.         } else {
  2186.         ckfree(varPtr->value.string);
  2187.         }
  2188.         varPtr->valueSpace = 0;
  2189.     }
  2190.     varPtr->hPtr = NULL;
  2191.     varPtr->tracePtr = NULL;
  2192.     varPtr->flags = VAR_UNDEFINED;
  2193.     if (varPtr->refCount == 0) {
  2194.         ckfree((char *) varPtr);
  2195.     }
  2196.     }
  2197.     Tcl_DeleteHashTable(tablePtr);
  2198. }
  2199.  
  2200. /*
  2201.  *----------------------------------------------------------------------
  2202.  *
  2203.  * DeleteArray --
  2204.  *
  2205.  *    This procedure is called to free up everything in an array
  2206.  *    variable.  It's the caller's responsibility to make sure
  2207.  *    that the array is no longer accessible before this procedure
  2208.  *    is called.
  2209.  *
  2210.  * Results:
  2211.  *    None.
  2212.  *
  2213.  * Side effects:
  2214.  *    All storage associated with varPtr's array elements is deleted
  2215.  *    (including the hash table).  Delete trace procedures for
  2216.  *    array elements are invoked.
  2217.  *
  2218.  *----------------------------------------------------------------------
  2219.  */
  2220.  
  2221. static void
  2222. DeleteArray(iPtr, arrayName, varPtr, flags)
  2223.     Interp *iPtr;            /* Interpreter containing array. */
  2224.     char *arrayName;            /* Name of array (used for trace
  2225.                      * callbacks). */
  2226.     Var *varPtr;            /* Pointer to variable structure. */
  2227.     int flags;                /* Flags to pass to CallTraces:
  2228.                      * TCL_TRACE_UNSETS and sometimes
  2229.                      * TCL_INTERP_DESTROYED and/or
  2230.                      * TCL_GLOBAL_ONLY. */
  2231. {
  2232.     Tcl_HashSearch search;
  2233.     register Tcl_HashEntry *hPtr;
  2234.     register Var *elPtr;
  2235.     ActiveVarTrace *activePtr;
  2236.  
  2237.     DeleteSearches(varPtr);
  2238.     for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
  2239.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  2240.     elPtr = (Var *) Tcl_GetHashValue(hPtr);
  2241.     if (elPtr->valueSpace != 0) {
  2242.         /*
  2243.          * SPECIAL TRICK:  it's possible that the interpreter's result
  2244.          * currently points to this element (for example, a "set" or
  2245.          * "lappend" command was the last command in a procedure that's
  2246.          * being returned from).  If this is the case, then just pass
  2247.          * ownership of the value string to the Tcl interpreter.
  2248.          */
  2249.  
  2250.         if (iPtr->result == elPtr->value.string) {
  2251.         iPtr->freeProc = (Tcl_FreeProc *) free;
  2252.         } else {
  2253.         ckfree(elPtr->value.string);
  2254.         }
  2255.         elPtr->valueSpace = 0;
  2256.     }
  2257.     elPtr->hPtr = NULL;
  2258.     if (elPtr->tracePtr != NULL) {
  2259.         elPtr->flags &= ~VAR_TRACE_ACTIVE;
  2260.         (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName,
  2261.             Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags);
  2262.         while (elPtr->tracePtr != NULL) {
  2263.         VarTrace *tracePtr = elPtr->tracePtr;
  2264.         elPtr->tracePtr = tracePtr->nextPtr;
  2265.         ckfree((char *) tracePtr);
  2266.         }
  2267.         for (activePtr = iPtr->activeTracePtr; activePtr != NULL;
  2268.             activePtr = activePtr->nextPtr) {
  2269.         if (activePtr->varPtr == elPtr) {
  2270.             activePtr->nextTracePtr = NULL;
  2271.         }
  2272.         }
  2273.     }
  2274.     elPtr->flags = VAR_UNDEFINED;
  2275.     if (elPtr->refCount == 0) {
  2276.         ckfree((char *) elPtr);
  2277.     }
  2278.     }
  2279.     Tcl_DeleteHashTable(varPtr->value.tablePtr);
  2280.     ckfree((char *) varPtr->value.tablePtr);
  2281. }
  2282.  
  2283. /*
  2284.  *----------------------------------------------------------------------
  2285.  *
  2286.  * CleanupVar --
  2287.  *
  2288.  *    This procedure is called when it looks like it may be OK
  2289.  *    to free up the variable's record and hash table entry, and
  2290.  *    those of its containing parent.  It's called, for example,
  2291.  *    when a trace on a variable deletes the variable.
  2292.  *
  2293.  * Results:
  2294.  *    None.
  2295.  *
  2296.  * Side effects:
  2297.  *    If the variable (or its containing array) really is dead then
  2298.  *    its record, and possibly its hash table entry, gets freed up.
  2299.  *
  2300.  *----------------------------------------------------------------------
  2301.  */
  2302.  
  2303. static void
  2304. CleanupVar(varPtr, arrayPtr)
  2305.     Var *varPtr;        /* Pointer to variable that may be a
  2306.                  * candidate for being expunged. */
  2307.     Var *arrayPtr;        /* Array that contains the variable, or
  2308.                  * NULL if this variable isn't an array
  2309.                  * element. */
  2310. {
  2311.     if ((varPtr->flags & VAR_UNDEFINED) && (varPtr->refCount == 0)
  2312.         && (varPtr->tracePtr == NULL)) {
  2313.     if (varPtr->hPtr != NULL) {
  2314.         Tcl_DeleteHashEntry(varPtr->hPtr);
  2315.     }
  2316.     ckfree((char *) varPtr);
  2317.     }
  2318.     if (arrayPtr != NULL) {
  2319.     if ((arrayPtr->flags & VAR_UNDEFINED) && (arrayPtr->refCount == 0)
  2320.         && (arrayPtr->tracePtr == NULL)) {
  2321.         if (arrayPtr->hPtr != NULL) {
  2322.         Tcl_DeleteHashEntry(arrayPtr->hPtr);
  2323.         }
  2324.         ckfree((char *) arrayPtr);
  2325.     }
  2326.     }
  2327.     return;
  2328. }
  2329.  
  2330. /*
  2331.  *----------------------------------------------------------------------
  2332.  *
  2333.  * VarErrMsg --
  2334.  *
  2335.  *    Generate a reasonable error message describing why a variable
  2336.  *    operation failed.
  2337.  *
  2338.  * Results:
  2339.  *    None.
  2340.  *
  2341.  * Side effects:
  2342.  *    Interp->result is reset to hold a message identifying the
  2343.  *    variable given by part1 and part2 and describing why the
  2344.  *    variable operation failed.
  2345.  *
  2346.  *----------------------------------------------------------------------
  2347.  */
  2348.  
  2349. static void
  2350. VarErrMsg(interp, part1, part2, operation, reason)
  2351.     Tcl_Interp *interp;        /* Interpreter in which to record message. */
  2352.     char *part1, *part2;    /* Variable's two-part name. */
  2353.     char *operation;        /* String describing operation that failed,
  2354.                  * e.g. "read", "set", or "unset". */
  2355.     char *reason;        /* String describing why operation failed. */
  2356. {
  2357.     Tcl_ResetResult(interp);
  2358.     Tcl_AppendResult(interp, "can't ", operation, " \"", part1, (char *) NULL);
  2359.     if (part2 != NULL) {
  2360.     Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
  2361.     }
  2362.     Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
  2363. }
  2364.