home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tcl7.0b1 / tclCmdMZ.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-17  |  41.0 KB  |  1,650 lines
  1. /* 
  2.  * tclCmdMZ.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    M to Z.  It contains only commands in the generic core (i.e.
  7.  *    those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * All rights reserved.
  11.  *
  12.  * Permission is hereby granted, without written agreement and without
  13.  * license or royalty fees, to use, copy, modify, and distribute this
  14.  * software and its documentation for any purpose, provided that the
  15.  * above copyright notice and the following two paragraphs appear in
  16.  * all copies of this software.
  17.  * 
  18.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  19.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  20.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  21.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  22.  *
  23.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  24.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  25.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  26.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  27.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  28.  */
  29.  
  30. #ifndef lint
  31. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.32 93/06/17 13:33:28 ouster Exp $ SPRITE (Berkeley)";
  32. #endif
  33.  
  34. #include "tclInt.h"
  35.  
  36. /*
  37.  * Structure used to hold information about variable traces:
  38.  */
  39.  
  40. typedef struct {
  41.     int flags;            /* Operations for which Tcl command is
  42.                  * to be invoked. */
  43.     char *errMsg;        /* Error message returned from Tcl command,
  44.                  * or NULL.  Malloc'ed. */
  45.     int length;            /* Number of non-NULL chars. in command. */
  46.     char command[4];        /* Space for Tcl command to invoke.  Actual
  47.                  * size will be as large as necessary to
  48.                  * hold command.  This field must be the
  49.                  * last in the structure, so that it can
  50.                  * be larger than 4 bytes. */
  51. } TraceVarInfo;
  52.  
  53. /*
  54.  * Forward declarations for procedures defined in this file:
  55.  */
  56.  
  57. static char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  58.                 Tcl_Interp *interp, char *name1, char *name2,
  59.                 int flags));
  60.  
  61. /*
  62.  *----------------------------------------------------------------------
  63.  *
  64.  * Tcl_RegexpCmd --
  65.  *
  66.  *    This procedure is invoked to process the "regexp" Tcl command.
  67.  *    See the user documentation for details on what it does.
  68.  *
  69.  * Results:
  70.  *    A standard Tcl result.
  71.  *
  72.  * Side effects:
  73.  *    See the user documentation.
  74.  *
  75.  *----------------------------------------------------------------------
  76.  */
  77.  
  78.     /* ARGSUSED */
  79. int
  80. Tcl_RegexpCmd(dummy, interp, argc, argv)
  81.     ClientData dummy;            /* Not used. */
  82.     Tcl_Interp *interp;            /* Current interpreter. */
  83.     int argc;                /* Number of arguments. */
  84.     char **argv;            /* Argument strings. */
  85. {
  86.     int noCase = 0;
  87.     int indices = 0;
  88.     regexp *regexpPtr;
  89.     char **argPtr, *string;
  90.     int match, i;
  91.  
  92.     if (argc < 3) {
  93.     wrongNumArgs:
  94.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  95.         " ?switches? exp string ?matchVar? ?subMatchVar ",
  96.         "subMatchVar ...?\"", (char *) NULL);
  97.     return TCL_ERROR;
  98.     }
  99.     argPtr = argv+1;
  100.     argc--;
  101.     while ((argc > 0) && (argPtr[0][0] == '-')) {
  102.     if (strcmp(argPtr[0], "-indices") == 0) {
  103.         indices = 1;
  104.     } else if (strcmp(argPtr[0], "-nocase") == 0) {
  105.         noCase = 1;
  106.     } else if (strcmp(argPtr[0], "--") == 0) {
  107.         argPtr++;
  108.         argc--;
  109.         break;
  110.     } else {
  111.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  112.             "\": must be -indices, -nocase, or --", (char *) NULL);
  113.         return TCL_ERROR;
  114.     }
  115.     argPtr++;
  116.     argc--;
  117.     }
  118.     if (argc < 2) {
  119.     goto wrongNumArgs;
  120.     }
  121.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  122.     if (regexpPtr == NULL) {
  123.     return TCL_ERROR;
  124.     }
  125.  
  126.     /*
  127.      * Convert the string to lower case, if desired, and perform
  128.      * the match.
  129.      */
  130.  
  131.     if (noCase) {
  132.     register char *dst, *src;
  133.  
  134.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  135.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  136.         if (isupper(*src)) {
  137.         *dst = tolower(*src);
  138.         } else {
  139.         *dst = *src;
  140.         }
  141.     }
  142.     *dst = 0;
  143.     } else {
  144.     string = argPtr[1];
  145.     }
  146.     tclRegexpError = NULL;
  147.     match = regexec(regexpPtr, string, string);
  148.     if (string != argPtr[1]) {
  149.     ckfree(string);
  150.     }
  151.     if (tclRegexpError != NULL) {
  152.     Tcl_AppendResult(interp, "error while matching pattern: ",
  153.         tclRegexpError, (char *) NULL);
  154.     return TCL_ERROR;
  155.     }
  156.     if (!match) {
  157.     interp->result = "0";
  158.     return TCL_OK;
  159.     }
  160.  
  161.     /*
  162.      * If additional variable names have been specified, return
  163.      * index information in those variables.
  164.      */
  165.  
  166.     argc -= 2;
  167.     if (argc > NSUBEXP) {
  168.     interp->result = "too many substring variables";
  169.     return TCL_ERROR;
  170.     }
  171.     for (i = 0; i < argc; i++) {
  172.     char *result, info[50];
  173.  
  174.     if (regexpPtr->startp[i] == NULL) {
  175.         if (indices) {
  176.         result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  177.         } else {
  178.         result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  179.         }
  180.     } else {
  181.         if (indices) {
  182.         sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  183.             regexpPtr->endp[i] - string - 1);
  184.         result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  185.         } else {
  186.         char savedChar, *first, *last;
  187.  
  188.         first = argPtr[1] + (regexpPtr->startp[i] - string);
  189.         last = argPtr[1] + (regexpPtr->endp[i] - string);
  190.         savedChar = *last;
  191.         *last = 0;
  192.         result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  193.         *last = savedChar;
  194.         }
  195.     }
  196.     if (result == NULL) {
  197.         Tcl_AppendResult(interp, "couldn't set variable \"",
  198.             argPtr[i+2], "\"", (char *) NULL);
  199.         return TCL_ERROR;
  200.     }
  201.     }
  202.     interp->result = "1";
  203.     return TCL_OK;
  204. }
  205.  
  206. /*
  207.  *----------------------------------------------------------------------
  208.  *
  209.  * Tcl_RegsubCmd --
  210.  *
  211.  *    This procedure is invoked to process the "regsub" Tcl command.
  212.  *    See the user documentation for details on what it does.
  213.  *
  214.  * Results:
  215.  *    A standard Tcl result.
  216.  *
  217.  * Side effects:
  218.  *    See the user documentation.
  219.  *
  220.  *----------------------------------------------------------------------
  221.  */
  222.  
  223.     /* ARGSUSED */
  224. int
  225. Tcl_RegsubCmd(dummy, interp, argc, argv)
  226.     ClientData dummy;            /* Not used. */
  227.     Tcl_Interp *interp;            /* Current interpreter. */
  228.     int argc;                /* Number of arguments. */
  229.     char **argv;            /* Argument strings. */
  230. {
  231.     int noCase = 0, all = 0;
  232.     regexp *regexpPtr;
  233.     char *string, *p, *firstChar, *newValue, **argPtr;
  234.     int match, result, flags, anyMatches;
  235.     register char *src, c;
  236.  
  237.     if (argc < 5) {
  238.     wrongNumArgs:
  239.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  240.         " ?switches? exp string subSpec varName\"", (char *) NULL);
  241.     return TCL_ERROR;
  242.     }
  243.     argPtr = argv+1;
  244.     argc--;
  245.     while (argPtr[0][0] == '-') {
  246.     if (strcmp(argPtr[0], "-nocase") == 0) {
  247.         noCase = 1;
  248.     } else if (strcmp(argPtr[0], "-all") == 0) {
  249.         all = 1;
  250.     } else if (strcmp(argPtr[0], "--") == 0) {
  251.         argPtr++;
  252.         argc--;
  253.         break;
  254.     } else {
  255.         Tcl_AppendResult(interp, "bad switch \"", argPtr[0],
  256.             "\": must be -all, -nocase, or --", (char *) NULL);
  257.         return TCL_ERROR;
  258.     }
  259.     argPtr++;
  260.     argc--;
  261.     }
  262.     if (argc != 4) {
  263.     goto wrongNumArgs;
  264.     }
  265.     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  266.     if (regexpPtr == NULL) {
  267.     return TCL_ERROR;
  268.     }
  269.  
  270.     /*
  271.      * Convert the string to lower case, if desired.
  272.      */
  273.  
  274.     if (noCase) {
  275.     register char *dst;
  276.  
  277.     string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  278.     for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  279.         if (isupper(*src)) {
  280.         *dst = tolower(*src);
  281.         } else {
  282.         *dst = *src;
  283.         }
  284.     }
  285.     *dst = 0;
  286.     } else {
  287.     string = argPtr[1];
  288.     }
  289.  
  290.     /*
  291.      * The following loop is to handle multiple matches within the
  292.      * same source string;  each iteration handles one match and its
  293.      * corresponding substitution.  If "-all" hasn't been specified
  294.      * then the loop body only gets executed once.
  295.      */
  296.  
  297.     flags = 0;
  298.     anyMatches = 0;
  299.     for (p = string; *p != 0; ) {
  300.     tclRegexpError = NULL;
  301.     match = regexec(regexpPtr, p, string);
  302.     if (tclRegexpError != NULL) {
  303.         Tcl_AppendResult(interp, "error while matching pattern: ",
  304.             tclRegexpError, (char *) NULL);
  305.         result = TCL_ERROR;
  306.         goto done;
  307.     }
  308.     if (!match) {
  309.         break;
  310.     }
  311.     anyMatches = 1;
  312.  
  313.     /*
  314.      * Copy the portion of the source string before the match to the
  315.      * result variable.
  316.      */
  317.     
  318.     src = argPtr[1] + (regexpPtr->startp[0] - string);
  319.     c = *src;
  320.     *src = 0;
  321.     newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  322.         flags);
  323.     *src = c;
  324.     flags = TCL_APPEND_VALUE;
  325.     if (newValue == NULL) {
  326.         cantSet:
  327.         Tcl_AppendResult(interp, "couldn't set variable \"",
  328.             argPtr[3], "\"", (char *) NULL);
  329.         result = TCL_ERROR;
  330.         goto done;
  331.     }
  332.     
  333.     /*
  334.      * Append the subSpec argument to the variable, making appropriate
  335.      * substitutions.  This code is a bit hairy because of the backslash
  336.      * conventions and because the code saves up ranges of characters in
  337.      * subSpec to reduce the number of calls to Tcl_SetVar.
  338.      */
  339.     
  340.     for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  341.         int index;
  342.     
  343.         if (c == '&') {
  344.         index = 0;
  345.         } else if (c == '\\') {
  346.         c = src[1];
  347.         if ((c >= '0') && (c <= '9')) {
  348.             index = c - '0';
  349.         } else if ((c == '\\') || (c == '&')) {
  350.             *src = c;
  351.             src[1] = 0;
  352.             newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  353.                 TCL_APPEND_VALUE);
  354.             *src = '\\';
  355.             src[1] = c;
  356.             if (newValue == NULL) {
  357.             goto cantSet;
  358.             }
  359.             firstChar = src+2;
  360.             src++;
  361.             continue;
  362.         } else {
  363.             continue;
  364.         }
  365.         } else {
  366.         continue;
  367.         }
  368.         if (firstChar != src) {
  369.         c = *src;
  370.         *src = 0;
  371.         newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  372.             TCL_APPEND_VALUE);
  373.         *src = c;
  374.         if (newValue == NULL) {
  375.             goto cantSet;
  376.         }
  377.         }
  378.         if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  379.             && (regexpPtr->endp[index] != NULL)) {
  380.         char *first, *last, saved;
  381.     
  382.         first = argPtr[1] + (regexpPtr->startp[index] - string);
  383.         last = argPtr[1] + (regexpPtr->endp[index] - string);
  384.         saved = *last;
  385.         *last = 0;
  386.         newValue = Tcl_SetVar(interp, argPtr[3], first,
  387.             TCL_APPEND_VALUE);
  388.         *last = saved;
  389.         if (newValue == NULL) {
  390.             goto cantSet;
  391.         }
  392.         }
  393.         if (*src == '\\') {
  394.         src++;
  395.         }
  396.         firstChar = src+1;
  397.     }
  398.     if (firstChar != src) {
  399.         if (Tcl_SetVar(interp, argPtr[3], firstChar,
  400.             TCL_APPEND_VALUE) == NULL) {
  401.         goto cantSet;
  402.         }
  403.     }
  404.     if (regexpPtr->endp[0] == p) {
  405.         char tmp[2];
  406.  
  407.         /*
  408.          * Always consume at least one character of the input string
  409.          * in order to prevent infinite loops.
  410.          */
  411.  
  412.         tmp[0] = argPtr[1][p - string];
  413.         tmp[1] = 0;
  414.         newValue = Tcl_SetVar(interp, argPtr[3], tmp, flags);
  415.         if (newValue == NULL) {
  416.         goto cantSet;
  417.         }
  418.         p = regexpPtr->endp[0] + 1;
  419.     } else {
  420.         p = regexpPtr->endp[0];
  421.     }
  422.     if (!all) {
  423.         break;
  424.     }
  425.     }
  426.  
  427.     /*
  428.      * Copy the portion of the source string after the last match to the
  429.      * result variable.
  430.      */
  431.  
  432.     if (*p != 0) {
  433.     if (Tcl_SetVar(interp, argPtr[3], p, flags) == NULL) {
  434.         goto cantSet;
  435.     }
  436.     }
  437.     if (anyMatches) {
  438.     interp->result = "1";
  439.     } else {
  440.     interp->result = "0";
  441.     }
  442.     result = TCL_OK;
  443.  
  444.     done:
  445.     if (string != argPtr[1]) {
  446.     ckfree(string);
  447.     }
  448.     return result;
  449. }
  450.  
  451. /*
  452.  *----------------------------------------------------------------------
  453.  *
  454.  * Tcl_RenameCmd --
  455.  *
  456.  *    This procedure is invoked to process the "rename" Tcl command.
  457.  *    See the user documentation for details on what it does.
  458.  *
  459.  * Results:
  460.  *    A standard Tcl result.
  461.  *
  462.  * Side effects:
  463.  *    See the user documentation.
  464.  *
  465.  *----------------------------------------------------------------------
  466.  */
  467.  
  468.     /* ARGSUSED */
  469. int
  470. Tcl_RenameCmd(dummy, interp, argc, argv)
  471.     ClientData dummy;            /* Not used. */
  472.     Tcl_Interp *interp;            /* Current interpreter. */
  473.     int argc;                /* Number of arguments. */
  474.     char **argv;            /* Argument strings. */
  475. {
  476.     register Command *cmdPtr;
  477.     Interp *iPtr = (Interp *) interp;
  478.     Tcl_HashEntry *hPtr;
  479.     int new;
  480.  
  481.     if (argc != 3) {
  482.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  483.         " oldName newName\"", (char *) NULL);
  484.     return TCL_ERROR;
  485.     }
  486.     if (argv[2][0] == '\0') {
  487.     if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  488.         Tcl_AppendResult(interp, "can't delete \"", argv[1],
  489.             "\": command doesn't exist", (char *) NULL);
  490.         return TCL_ERROR;
  491.     }
  492.     return TCL_OK;
  493.     }
  494.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  495.     if (hPtr != NULL) {
  496.     Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  497.         "\": command already exists", (char *) NULL);
  498.     return TCL_ERROR;
  499.     }
  500.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  501.     if (hPtr == NULL) {
  502.     Tcl_AppendResult(interp, "can't rename \"", argv[1],
  503.         "\":  command doesn't exist", (char *) NULL);
  504.     return TCL_ERROR;
  505.     }
  506.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  507.     Tcl_DeleteHashEntry(hPtr);
  508.     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  509.     Tcl_SetHashValue(hPtr, cmdPtr);
  510.     return TCL_OK;
  511. }
  512.  
  513. /*
  514.  *----------------------------------------------------------------------
  515.  *
  516.  * Tcl_ReturnCmd --
  517.  *
  518.  *    This procedure is invoked to process the "return" Tcl command.
  519.  *    See the user documentation for details on what it does.
  520.  *
  521.  * Results:
  522.  *    A standard Tcl result.
  523.  *
  524.  * Side effects:
  525.  *    See the user documentation.
  526.  *
  527.  *----------------------------------------------------------------------
  528.  */
  529.  
  530.     /* ARGSUSED */
  531. int
  532. Tcl_ReturnCmd(dummy, interp, argc, argv)
  533.     ClientData dummy;            /* Not used. */
  534.     Tcl_Interp *interp;            /* Current interpreter. */
  535.     int argc;                /* Number of arguments. */
  536.     char **argv;            /* Argument strings. */
  537. {
  538.     Interp *iPtr = (Interp *) interp;
  539.     int c;
  540.  
  541.     if (argc > 3) {
  542.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  543.         " ?value? ?code?\"", (char *) NULL);
  544.     return TCL_ERROR;
  545.     }
  546.     if (argc >= 2) {
  547.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  548.     }
  549.     iPtr->returnCode = TCL_OK;
  550.     if (argc == 3) {
  551.     c = argv[2][0];
  552.     if ((c == 'o') && (strcmp(argv[2], "ok") == 0)) {
  553.         iPtr->returnCode = TCL_OK;
  554.     } else if ((c == 'e') && (strcmp(argv[2], "error") == 0)) {
  555.         iPtr->returnCode = TCL_ERROR;
  556.     } else if ((c == 'r') && (strcmp(argv[2], "return") == 0)) {
  557.         iPtr->returnCode = TCL_RETURN;
  558.     } else if ((c == 'b') && (strcmp(argv[2], "break") == 0)) {
  559.         iPtr->returnCode = TCL_BREAK;
  560.     } else if ((c == 'c') && (strcmp(argv[2], "continue") == 0)) {
  561.         iPtr->returnCode = TCL_CONTINUE;
  562.     } else if (Tcl_GetInt(interp, argv[2], &iPtr->returnCode) != TCL_OK) {
  563.         Tcl_ResetResult(interp);
  564.         Tcl_AppendResult(interp, "bad completion code \"",
  565.             argv[2], "\": must be ok, error, return, break, ",
  566.             "continue, or an integer", (char *) NULL);
  567.         return TCL_ERROR;
  568.     }
  569.     }
  570.  
  571.     return TCL_RETURN;
  572. }
  573.  
  574. /*
  575.  *----------------------------------------------------------------------
  576.  *
  577.  * Tcl_ScanCmd --
  578.  *
  579.  *    This procedure is invoked to process the "scan" Tcl command.
  580.  *    See the user documentation for details on what it does.
  581.  *
  582.  * Results:
  583.  *    A standard Tcl result.
  584.  *
  585.  * Side effects:
  586.  *    See the user documentation.
  587.  *
  588.  *----------------------------------------------------------------------
  589.  */
  590.  
  591.     /* ARGSUSED */
  592. int
  593. Tcl_ScanCmd(dummy, interp, argc, argv)
  594.     ClientData dummy;            /* Not used. */
  595.     Tcl_Interp *interp;            /* Current interpreter. */
  596.     int argc;                /* Number of arguments. */
  597.     char **argv;            /* Argument strings. */
  598. {
  599.     int arg1Length;            /* Number of bytes in argument to be
  600.                      * scanned.  This gives an upper limit
  601.                      * on string field sizes. */
  602. #   define MAX_FIELDS 20
  603.     typedef struct {
  604.     char fmt;            /* Format for field. */
  605.     int size;            /* How many bytes to allow for
  606.                      * field. */
  607.     char *location;            /* Where field will be stored. */
  608.     } Field;
  609.     Field fields[MAX_FIELDS];        /* Info about all the fields in the
  610.                      * format string. */
  611.     register Field *curField;
  612.     int numFields = 0;            /* Number of fields actually
  613.                      * specified. */
  614.     int suppress;            /* Current field is assignment-
  615.                      * suppressed. */
  616.     int totalSize = 0;            /* Number of bytes needed to store
  617.                      * all results combined. */
  618.     char *results;            /* Where scanned output goes.  */
  619.     int numScanned;            /* sscanf's result. */
  620.     register char *fmt;
  621.     int i, widthSpecified;
  622.  
  623.     if (argc < 3) {
  624.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  625.         " string format ?varName varName ...?\"", (char *) NULL);
  626.     return TCL_ERROR;
  627.     }
  628.  
  629.     /*
  630.      * This procedure operates in four stages:
  631.      * 1. Scan the format string, collecting information about each field.
  632.      * 2. Allocate an array to hold all of the scanned fields.
  633.      * 3. Call sscanf to do all the dirty work, and have it store the
  634.      *    parsed fields in the array.
  635.      * 4. Pick off the fields from the array and assign them to variables.
  636.      */
  637.  
  638.     arg1Length = (strlen(argv[1]) + 4) & ~03;
  639.     for (fmt = argv[2]; *fmt != 0; fmt++) {
  640.     if (*fmt != '%') {
  641.         continue;
  642.     }
  643.     fmt++;
  644.     if (*fmt == '%') {
  645.         continue;
  646.     }
  647.     if (*fmt == '*') {
  648.         suppress = 1;
  649.         fmt++;
  650.     } else {
  651.         suppress = 0;
  652.     }
  653.     widthSpecified = 0;
  654.     while (isdigit(*fmt)) {
  655.         widthSpecified = 1;
  656.         fmt++;
  657.     }
  658.     if (suppress) {
  659.         continue;
  660.     }
  661.     if (numFields == MAX_FIELDS) {
  662.         interp->result = "too many fields to scan";
  663.         return TCL_ERROR;
  664.     }
  665.     curField = &fields[numFields];
  666.     numFields++;
  667.     switch (*fmt) {
  668.         case 'D':
  669.         case 'O':
  670.         case 'X':
  671.         case 'd':
  672.         case 'o':
  673.         case 'x':
  674.         curField->fmt = 'd';
  675.         curField->size = sizeof(int);
  676.         break;
  677.  
  678.         case 's':
  679.         curField->fmt = 's';
  680.         curField->size = arg1Length;
  681.         break;
  682.  
  683.         case 'c':
  684.                 if (widthSpecified) {
  685.                     interp->result = 
  686.                          "field width may not be specified in %c conversion";
  687.                     return TCL_ERROR;
  688.                 }
  689.         curField->fmt = 'c';
  690.         curField->size = sizeof(int);
  691.         break;
  692.  
  693.         case 'E':
  694.         case 'F':
  695.         curField->fmt = 'F';
  696.         curField->size = sizeof(double);
  697.         break;
  698.  
  699.         case 'e':
  700.         case 'f':
  701.         curField->fmt = 'f';
  702.         curField->size = sizeof(float);
  703.         break;
  704.  
  705.         case '[':
  706.         curField->fmt = 's';
  707.         curField->size = arg1Length;
  708.         do {
  709.             fmt++;
  710.         } while (*fmt != ']');
  711.         break;
  712.  
  713.         default:
  714.         sprintf(interp->result, "bad scan conversion character \"%c\"",
  715.             *fmt);
  716.         return TCL_ERROR;
  717.     }
  718.     totalSize += curField->size;
  719.     }
  720.  
  721.     if (numFields != (argc-3)) {
  722.     interp->result =
  723.         "different numbers of variable names and field specifiers";
  724.     return TCL_ERROR;
  725.     }
  726.  
  727.     /*
  728.      * Step 2:
  729.      */
  730.  
  731.     results = (char *) ckalloc((unsigned) totalSize);
  732.     for (i = 0, totalSize = 0, curField = fields;
  733.         i < numFields; i++, curField++) {
  734.     curField->location = results + totalSize;
  735.     totalSize += curField->size;
  736.     }
  737.  
  738.     /*
  739.      * Fill in the remaining fields with NULL;  the only purpose of
  740.      * this is to keep some memory analyzers, like Purify, from
  741.      * complaining.
  742.      */
  743.  
  744.     for ( ; i < MAX_FIELDS; i++, curField++) {
  745.     curField->location = NULL;
  746.     }
  747.  
  748.     /*
  749.      * Step 3:
  750.      */
  751.  
  752.     numScanned = sscanf(argv[1], argv[2],
  753.         fields[0].location, fields[1].location, fields[2].location,
  754.         fields[3].location, fields[4].location, fields[5].location,
  755.         fields[6].location, fields[7].location, fields[8].location,
  756.         fields[9].location, fields[10].location, fields[11].location,
  757.         fields[12].location, fields[13].location, fields[14].location,
  758.         fields[15].location, fields[16].location, fields[17].location,
  759.         fields[18].location, fields[19].location);
  760.  
  761.     /*
  762.      * Step 4:
  763.      */
  764.  
  765.     if (numScanned < numFields) {
  766.     numFields = numScanned;
  767.     }
  768.     for (i = 0, curField = fields; i < numFields; i++, curField++) {
  769.     switch (curField->fmt) {
  770.         char string[TCL_DOUBLE_SPACE];
  771.  
  772.         case 'd':
  773.         sprintf(string, "%d", *((int *) curField->location));
  774.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  775.             storeError:
  776.             Tcl_AppendResult(interp,
  777.                 "couldn't set variable \"", argv[i+3], "\"",
  778.                 (char *) NULL);
  779.             ckfree((char *) results);
  780.             return TCL_ERROR;
  781.         }
  782.         break;
  783.  
  784.         case 'c':
  785.         sprintf(string, "%d", *((char *) curField->location) & 0xff);
  786.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  787.             goto storeError;
  788.         }
  789.         break;
  790.  
  791.         case 's':
  792.         if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  793.             == NULL) {
  794.             goto storeError;
  795.         }
  796.         break;
  797.  
  798.         case 'F':
  799.         Tcl_PrintDouble(interp, *((double *) curField->location),
  800.             string);
  801.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  802.             goto storeError;
  803.         }
  804.         break;
  805.  
  806.         case 'f':
  807.         Tcl_PrintDouble(interp, *((float *) curField->location),
  808.             string);
  809.         if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  810.             goto storeError;
  811.         }
  812.         break;
  813.     }
  814.     }
  815.     ckfree(results);
  816.     sprintf(interp->result, "%d", numScanned);
  817.     return TCL_OK;
  818. }
  819.  
  820. /*
  821.  *----------------------------------------------------------------------
  822.  *
  823.  * Tcl_SplitCmd --
  824.  *
  825.  *    This procedure is invoked to process the "split" Tcl command.
  826.  *    See the user documentation for details on what it does.
  827.  *
  828.  * Results:
  829.  *    A standard Tcl result.
  830.  *
  831.  * Side effects:
  832.  *    See the user documentation.
  833.  *
  834.  *----------------------------------------------------------------------
  835.  */
  836.  
  837.     /* ARGSUSED */
  838. int
  839. Tcl_SplitCmd(dummy, interp, argc, argv)
  840.     ClientData dummy;            /* Not used. */
  841.     Tcl_Interp *interp;            /* Current interpreter. */
  842.     int argc;                /* Number of arguments. */
  843.     char **argv;            /* Argument strings. */
  844. {
  845.     char *splitChars;
  846.     register char *p, *p2;
  847.     char *elementStart;
  848.  
  849.     if (argc == 2) {
  850.     splitChars = " \n\t\r";
  851.     } else if (argc == 3) {
  852.     splitChars = argv[2];
  853.     } else {
  854.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  855.         " string ?splitChars?\"", (char *) NULL);
  856.     return TCL_ERROR;
  857.     }
  858.  
  859.     /*
  860.      * Handle the special case of splitting on every character.
  861.      */
  862.  
  863.     if (*splitChars == 0) {
  864.     char string[2];
  865.     string[1] = 0;
  866.     for (p = argv[1]; *p != 0; p++) {
  867.         string[0] = *p;
  868.         Tcl_AppendElement(interp, string);
  869.     }
  870.     return TCL_OK;
  871.     }
  872.  
  873.     /*
  874.      * Normal case: split on any of a given set of characters.
  875.      * Discard instances of the split characters.
  876.      */
  877.  
  878.     for (p = elementStart = argv[1]; *p != 0; p++) {
  879.     char c = *p;
  880.     for (p2 = splitChars; *p2 != 0; p2++) {
  881.         if (*p2 == c) {
  882.         *p = 0;
  883.         Tcl_AppendElement(interp, elementStart);
  884.         *p = c;
  885.         elementStart = p+1;
  886.         break;
  887.         }
  888.     }
  889.     }
  890.     if (p != argv[1]) {
  891.     Tcl_AppendElement(interp, elementStart);
  892.     }
  893.     return TCL_OK;
  894. }
  895.  
  896. /*
  897.  *----------------------------------------------------------------------
  898.  *
  899.  * Tcl_StringCmd --
  900.  *
  901.  *    This procedure is invoked to process the "string" Tcl command.
  902.  *    See the user documentation for details on what it does.
  903.  *
  904.  * Results:
  905.  *    A standard Tcl result.
  906.  *
  907.  * Side effects:
  908.  *    See the user documentation.
  909.  *
  910.  *----------------------------------------------------------------------
  911.  */
  912.  
  913.     /* ARGSUSED */
  914. int
  915. Tcl_StringCmd(dummy, interp, argc, argv)
  916.     ClientData dummy;            /* Not used. */
  917.     Tcl_Interp *interp;            /* Current interpreter. */
  918.     int argc;                /* Number of arguments. */
  919.     char **argv;            /* Argument strings. */
  920. {
  921.     int length;
  922.     register char *p, c;
  923.     int match;
  924.     int first;
  925.     int left = 0, right = 0;
  926.  
  927.     if (argc < 2) {
  928.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  929.         " option arg ?arg ...?\"", (char *) NULL);
  930.     return TCL_ERROR;
  931.     }
  932.     c = argv[1][0];
  933.     length = strlen(argv[1]);
  934.     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  935.     if (argc != 4) {
  936.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  937.             " compare string1 string2\"", (char *) NULL);
  938.         return TCL_ERROR;
  939.     }
  940.     match = strcmp(argv[2], argv[3]);
  941.     if (match > 0) {
  942.         interp->result = "1";
  943.     } else if (match < 0) {
  944.         interp->result = "-1";
  945.     } else {
  946.         interp->result = "0";
  947.     }
  948.     return TCL_OK;
  949.     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  950.     if (argc != 4) {
  951.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  952.             " first string1 string2\"", (char *) NULL);
  953.         return TCL_ERROR;
  954.     }
  955.     first = 1;
  956.  
  957.     firstLast:
  958.     match = -1;
  959.     c = *argv[2];
  960.     length = strlen(argv[2]);
  961.     for (p = argv[3]; *p != 0; p++) {
  962.         if (*p != c) {
  963.         continue;
  964.         }
  965.         if (strncmp(argv[2], p, length) == 0) {
  966.         match = p-argv[3];
  967.         if (first) {
  968.             break;
  969.         }
  970.         }
  971.     }
  972.     sprintf(interp->result, "%d", match);
  973.     return TCL_OK;
  974.     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  975.     int index;
  976.  
  977.     if (argc != 4) {
  978.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  979.             " index string charIndex\"", (char *) NULL);
  980.         return TCL_ERROR;
  981.     }
  982.     if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  983.         return TCL_ERROR;
  984.     }
  985.     if ((index >= 0) && (index < strlen(argv[2]))) {
  986.         interp->result[0] = argv[2][index];
  987.         interp->result[1] = 0;
  988.     }
  989.     return TCL_OK;
  990.     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  991.         && (length >= 2)) {
  992.     if (argc != 4) {
  993.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  994.             " last string1 string2\"", (char *) NULL);
  995.         return TCL_ERROR;
  996.     }
  997.     first = 0;
  998.     goto firstLast;
  999.     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  1000.         && (length >= 2)) {
  1001.     if (argc != 3) {
  1002.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1003.             " length string\"", (char *) NULL);
  1004.         return TCL_ERROR;
  1005.     }
  1006.     sprintf(interp->result, "%d", strlen(argv[2]));
  1007.     return TCL_OK;
  1008.     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  1009.     if (argc != 4) {
  1010.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1011.             " match pattern string\"", (char *) NULL);
  1012.         return TCL_ERROR;
  1013.     }
  1014.     if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  1015.         interp->result = "1";
  1016.     } else {
  1017.         interp->result = "0";
  1018.     }
  1019.     return TCL_OK;
  1020.     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  1021.     int first, last, stringLength;
  1022.  
  1023.     if (argc != 5) {
  1024.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1025.             " range string first last\"", (char *) NULL);
  1026.         return TCL_ERROR;
  1027.     }
  1028.     stringLength = strlen(argv[2]);
  1029.     if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  1030.         return TCL_ERROR;
  1031.     }
  1032.     if ((*argv[4] == 'e')
  1033.         && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  1034.         last = stringLength-1;
  1035.     } else {
  1036.         if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  1037.         Tcl_ResetResult(interp);
  1038.         Tcl_AppendResult(interp,
  1039.             "expected integer or \"end\" but got \"",
  1040.             argv[4], "\"", (char *) NULL);
  1041.         return TCL_ERROR;
  1042.         }
  1043.     }
  1044.     if (first < 0) {
  1045.         first = 0;
  1046.     }
  1047.     if (last >= stringLength) {
  1048.         last = stringLength-1;
  1049.     }
  1050.     if (last >= first) {
  1051.         char saved, *p;
  1052.  
  1053.         p = argv[2] + last + 1;
  1054.         saved = *p;
  1055.         *p = 0;
  1056.         Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  1057.         *p = saved;
  1058.     }
  1059.     return TCL_OK;
  1060.     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  1061.         && (length >= 3)) {
  1062.     register char *p;
  1063.  
  1064.     if (argc != 3) {
  1065.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1066.             " tolower string\"", (char *) NULL);
  1067.         return TCL_ERROR;
  1068.     }
  1069.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1070.     for (p = interp->result; *p != 0; p++) {
  1071.         if (isupper(*p)) {
  1072.         *p = tolower(*p);
  1073.         }
  1074.     }
  1075.     return TCL_OK;
  1076.     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1077.         && (length >= 3)) {
  1078.     register char *p;
  1079.  
  1080.     if (argc != 3) {
  1081.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1082.             " toupper string\"", (char *) NULL);
  1083.         return TCL_ERROR;
  1084.     }
  1085.     Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1086.     for (p = interp->result; *p != 0; p++) {
  1087.         if (islower(*p)) {
  1088.         *p = toupper(*p);
  1089.         }
  1090.     }
  1091.     return TCL_OK;
  1092.     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1093.         && (length == 4)) {
  1094.     char *trimChars;
  1095.     register char *p, *checkPtr;
  1096.  
  1097.     left = right = 1;
  1098.  
  1099.     trim:
  1100.     if (argc == 4) {
  1101.         trimChars = argv[3];
  1102.     } else if (argc == 3) {
  1103.         trimChars = " \t\n\r";
  1104.     } else {
  1105.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1106.             " ", argv[1], " string ?chars?\"", (char *) NULL);
  1107.         return TCL_ERROR;
  1108.     }
  1109.     p = argv[2];
  1110.     if (left) {
  1111.         for (c = *p; c != 0; p++, c = *p) {
  1112.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1113.             if (*checkPtr == 0) {
  1114.             goto doneLeft;
  1115.             }
  1116.         }
  1117.         }
  1118.     }
  1119.     doneLeft:
  1120.     Tcl_SetResult(interp, p, TCL_VOLATILE);
  1121.     if (right) {
  1122.         char *donePtr;
  1123.  
  1124.         p = interp->result + strlen(interp->result) - 1;
  1125.         donePtr = &interp->result[-1];
  1126.         for (c = *p; p != donePtr; p--, c = *p) {
  1127.         for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1128.             if (*checkPtr == 0) {
  1129.             goto doneRight;
  1130.             }
  1131.         }
  1132.         }
  1133.         doneRight:
  1134.         p[1] = 0;
  1135.     }
  1136.     return TCL_OK;
  1137.     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1138.         && (length > 4)) {
  1139.     left = 1;
  1140.     argv[1] = "trimleft";
  1141.     goto trim;
  1142.     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1143.         && (length > 4)) {
  1144.     right = 1;
  1145.     argv[1] = "trimright";
  1146.     goto trim;
  1147.     } else {
  1148.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1149.         "\": should be compare, first, index, last, length, match, ",
  1150.         "range, tolower, toupper, trim, trimleft, or trimright",
  1151.         (char *) NULL);
  1152.     return TCL_ERROR;
  1153.     }
  1154. }
  1155.  
  1156. /*
  1157.  *----------------------------------------------------------------------
  1158.  *
  1159.  * Tcl_SwitchCmd --
  1160.  *
  1161.  *    This procedure is invoked to process the "switch" Tcl command.
  1162.  *    See the user documentation for details on what it does.
  1163.  *
  1164.  * Results:
  1165.  *    A standard Tcl result.
  1166.  *
  1167.  * Side effects:
  1168.  *    See the user documentation.
  1169.  *
  1170.  *----------------------------------------------------------------------
  1171.  */
  1172.  
  1173.     /* ARGSUSED */
  1174. int
  1175. Tcl_SwitchCmd(dummy, interp, argc, argv)
  1176.     ClientData dummy;            /* Not used. */
  1177.     Tcl_Interp *interp;            /* Current interpreter. */
  1178.     int argc;                /* Number of arguments. */
  1179.     char **argv;            /* Argument strings. */
  1180. {
  1181. #define EXACT    0
  1182. #define GLOB    1
  1183. #define REGEXP    2
  1184.     int i, code, mode, matched;
  1185.     int body;
  1186.     char *string;
  1187.     int switchArgc, splitArgs;
  1188.     char **switchArgv;
  1189.  
  1190.     switchArgc = argc-1;
  1191.     switchArgv = argv+1;
  1192.     mode = EXACT;
  1193.     while ((switchArgc > 0) && (*switchArgv[0] == '-')) {
  1194.     if (strcmp(*switchArgv, "-exact") == 0) {
  1195.         mode = EXACT;
  1196.     } else if (strcmp(*switchArgv, "-glob") == 0) {
  1197.         mode = GLOB;
  1198.     } else if (strcmp(*switchArgv, "-regexp") == 0) {
  1199.         mode = REGEXP;
  1200.     } else if (strcmp(*switchArgv, "--") == 0) {
  1201.         switchArgc--;
  1202.         switchArgv++;
  1203.         break;
  1204.     } else {
  1205.         Tcl_AppendResult(interp, "bad option \"", switchArgv[0],
  1206.             "\": should be -exact, -glob, -regexp, or --",
  1207.             (char *) NULL);
  1208.         return TCL_ERROR;
  1209.     }
  1210.     switchArgc--;
  1211.     switchArgv++;
  1212.     }
  1213.     if (switchArgc < 2) {
  1214.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1215.         argv[0], " ?switches? string pattern body ... ?default body?\"",
  1216.         (char *) NULL);
  1217.     return TCL_ERROR;
  1218.     }
  1219.     string = *switchArgv;
  1220.     switchArgc--;
  1221.     switchArgv++;
  1222.  
  1223.     /*
  1224.      * If all of the pattern/command pairs are lumped into a single
  1225.      * argument, split them out again.
  1226.      */
  1227.  
  1228.     splitArgs = 0;
  1229.     if (switchArgc == 1) {
  1230.     code = Tcl_SplitList(interp, switchArgv[0], &switchArgc, &switchArgv);
  1231.     if (code != TCL_OK) {
  1232.         return code;
  1233.     }
  1234.     splitArgs = 1;
  1235.     }
  1236.  
  1237.     body = -1;
  1238.     for (i = 0; i < switchArgc; i += 2) {
  1239.     if (i == (switchArgc-1)) {
  1240.         interp->result = "extra switch pattern with no body";
  1241.         code = TCL_ERROR;
  1242.         goto cleanup;
  1243.     }
  1244.  
  1245.     /*
  1246.      * See if the pattern matches the string.
  1247.      */
  1248.  
  1249.     matched = 0;
  1250.     if ((*switchArgv[i] == 'd') && (i == switchArgc-2)
  1251.         && (strcmp(switchArgv[i], "default") == 0)) {
  1252.         matched = 1;
  1253.     } else {
  1254.         switch (mode) {
  1255.         case EXACT:
  1256.             matched = (strcmp(string, switchArgv[i]) == 0);
  1257.             break;
  1258.         case GLOB:
  1259.             matched = Tcl_StringMatch(string, switchArgv[i]);
  1260.             break;
  1261.         case REGEXP:
  1262.             matched = Tcl_RegExpMatch(interp, string, switchArgv[i]);
  1263.             if (matched < 0) {
  1264.             code = TCL_ERROR;
  1265.             goto cleanup;
  1266.             }
  1267.             break;
  1268.         }
  1269.     }
  1270.     if (!matched) {
  1271.         continue;
  1272.     }
  1273.  
  1274.     /*
  1275.      * We've got a match.  Find a body to execute, skipping bodies
  1276.      * that are "-".
  1277.      */
  1278.  
  1279.     for (body = i+1; ; body += 2) {
  1280.         if (body >= switchArgc) {
  1281.         Tcl_AppendResult(interp, "no body specified for pattern \"",
  1282.             switchArgv[i], "\"", (char *) NULL);
  1283.         code = TCL_ERROR;
  1284.         goto cleanup;
  1285.         }
  1286.         if ((switchArgv[body][0] != '-') || (switchArgv[body][1] != 0)) {
  1287.         break;
  1288.         }
  1289.     }
  1290.     code = Tcl_Eval(interp, switchArgv[body]);
  1291.     if (code == TCL_ERROR) {
  1292.         char msg[100];
  1293.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", switchArgv[i],
  1294.             interp->errorLine);
  1295.         Tcl_AddErrorInfo(interp, msg);
  1296.     }
  1297.     goto cleanup;
  1298.     }
  1299.  
  1300.     /*
  1301.      * Nothing matched:  return nothing.
  1302.      */
  1303.  
  1304.     code = TCL_OK;
  1305.  
  1306.     cleanup:
  1307.     if (splitArgs) {
  1308.     ckfree((char *) switchArgv);
  1309.     }
  1310.     return code;
  1311. }
  1312.  
  1313. /*
  1314.  *----------------------------------------------------------------------
  1315.  *
  1316.  * Tcl_TraceCmd --
  1317.  *
  1318.  *    This procedure is invoked to process the "trace" Tcl command.
  1319.  *    See the user documentation for details on what it does.
  1320.  *
  1321.  * Results:
  1322.  *    A standard Tcl result.
  1323.  *
  1324.  * Side effects:
  1325.  *    See the user documentation.
  1326.  *
  1327.  *----------------------------------------------------------------------
  1328.  */
  1329.  
  1330.     /* ARGSUSED */
  1331. int
  1332. Tcl_TraceCmd(dummy, interp, argc, argv)
  1333.     ClientData dummy;            /* Not used. */
  1334.     Tcl_Interp *interp;            /* Current interpreter. */
  1335.     int argc;                /* Number of arguments. */
  1336.     char **argv;            /* Argument strings. */
  1337. {
  1338.     char c;
  1339.     int length;
  1340.  
  1341.     if (argc < 2) {
  1342.     Tcl_AppendResult(interp, "too few args: should be \"",
  1343.         argv[0], " option [arg arg ...]\"", (char *) NULL);
  1344.     return TCL_ERROR;
  1345.     }
  1346.     c = argv[1][1];
  1347.     length = strlen(argv[1]);
  1348.     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1349.         && (length >= 2)) {
  1350.     char *p;
  1351.     int flags, length;
  1352.     TraceVarInfo *tvarPtr;
  1353.  
  1354.     if (argc != 5) {
  1355.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1356.             argv[0], " variable name ops command\"", (char *) NULL);
  1357.         return TCL_ERROR;
  1358.     }
  1359.  
  1360.     flags = 0;
  1361.     for (p = argv[3] ; *p != 0; p++) {
  1362.         if (*p == 'r') {
  1363.         flags |= TCL_TRACE_READS;
  1364.         } else if (*p == 'w') {
  1365.         flags |= TCL_TRACE_WRITES;
  1366.         } else if (*p == 'u') {
  1367.         flags |= TCL_TRACE_UNSETS;
  1368.         } else {
  1369.         goto badOps;
  1370.         }
  1371.     }
  1372.     if (flags == 0) {
  1373.         goto badOps;
  1374.     }
  1375.  
  1376.     length = strlen(argv[4]);
  1377.     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1378.         (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1379.     tvarPtr->flags = flags;
  1380.     tvarPtr->errMsg = NULL;
  1381.     tvarPtr->length = length;
  1382.     flags |= TCL_TRACE_UNSETS;
  1383.     strcpy(tvarPtr->command, argv[4]);
  1384.     if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1385.         (ClientData) tvarPtr) != TCL_OK) {
  1386.         ckfree((char *) tvarPtr);
  1387.         return TCL_ERROR;
  1388.     }
  1389.     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1390.         && (length >= 2)) == 0) {
  1391.     char *p;
  1392.     int flags, length;
  1393.     TraceVarInfo *tvarPtr;
  1394.     ClientData clientData;
  1395.  
  1396.     if (argc != 5) {
  1397.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1398.             argv[0], " vdelete name ops command\"", (char *) NULL);
  1399.         return TCL_ERROR;
  1400.     }
  1401.  
  1402.     flags = 0;
  1403.     for (p = argv[3] ; *p != 0; p++) {
  1404.         if (*p == 'r') {
  1405.         flags |= TCL_TRACE_READS;
  1406.         } else if (*p == 'w') {
  1407.         flags |= TCL_TRACE_WRITES;
  1408.         } else if (*p == 'u') {
  1409.         flags |= TCL_TRACE_UNSETS;
  1410.         } else {
  1411.         goto badOps;
  1412.         }
  1413.     }
  1414.     if (flags == 0) {
  1415.         goto badOps;
  1416.     }
  1417.  
  1418.     /*
  1419.      * Search through all of our traces on this variable to
  1420.      * see if there's one with the given command.  If so, then
  1421.      * delete the first one that matches.
  1422.      */
  1423.  
  1424.     length = strlen(argv[4]);
  1425.     clientData = 0;
  1426.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1427.         TraceVarProc, clientData)) != 0) {
  1428.         tvarPtr = (TraceVarInfo *) clientData;
  1429.         if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1430.             && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1431.         Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1432.             TraceVarProc, clientData);
  1433.         if (tvarPtr->errMsg != NULL) {
  1434.             ckfree(tvarPtr->errMsg);
  1435.         }
  1436.         ckfree((char *) tvarPtr);
  1437.         break;
  1438.         }
  1439.     }
  1440.     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1441.         && (length >= 2)) {
  1442.     ClientData clientData;
  1443.     char ops[4], *p;
  1444.     char *prefix = "{";
  1445.  
  1446.     if (argc != 3) {
  1447.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1448.             argv[0], " vinfo name\"", (char *) NULL);
  1449.         return TCL_ERROR;
  1450.     }
  1451.     clientData = 0;
  1452.     while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1453.         TraceVarProc, clientData)) != 0) {
  1454.         TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1455.         p = ops;
  1456.         if (tvarPtr->flags & TCL_TRACE_READS) {
  1457.         *p = 'r';
  1458.         p++;
  1459.         }
  1460.         if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1461.         *p = 'w';
  1462.         p++;
  1463.         }
  1464.         if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1465.         *p = 'u';
  1466.         p++;
  1467.         }
  1468.         *p = '\0';
  1469.         Tcl_AppendResult(interp, prefix, (char *) NULL);
  1470.         Tcl_AppendElement(interp, ops);
  1471.         Tcl_AppendElement(interp, tvarPtr->command);
  1472.         Tcl_AppendResult(interp, "}", (char *) NULL);
  1473.         prefix = " {";
  1474.     }
  1475.     } else {
  1476.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  1477.         "\": should be variable, vdelete, or vinfo",
  1478.         (char *) NULL);
  1479.     return TCL_ERROR;
  1480.     }
  1481.     return TCL_OK;
  1482.  
  1483.     badOps:
  1484.     Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1485.         "\": should be one or more of rwu", (char *) NULL);
  1486.     return TCL_ERROR;
  1487. }
  1488.  
  1489. /*
  1490.  *----------------------------------------------------------------------
  1491.  *
  1492.  * TraceVarProc --
  1493.  *
  1494.  *    This procedure is called to handle variable accesses that have
  1495.  *    been traced using the "trace" command.
  1496.  *
  1497.  * Results:
  1498.  *    Normally returns NULL.  If the trace command returns an error,
  1499.  *    then this procedure returns an error string.
  1500.  *
  1501.  * Side effects:
  1502.  *    Depends on the command associated with the trace.
  1503.  *
  1504.  *----------------------------------------------------------------------
  1505.  */
  1506.  
  1507.     /* ARGSUSED */
  1508. static char *
  1509. TraceVarProc(clientData, interp, name1, name2, flags)
  1510.     ClientData clientData;    /* Information about the variable trace. */
  1511.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1512.     char *name1;        /* Name of variable or array. */
  1513.     char *name2;        /* Name of element within array;  NULL means
  1514.                  * scalar variable is being referenced. */
  1515.     int flags;            /* OR-ed bits giving operation and other
  1516.                  * information. */
  1517. {
  1518.     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1519.     char *result;
  1520.     int code;
  1521.     Interp dummy;
  1522.     Tcl_DString cmd;
  1523.  
  1524.     result = NULL;
  1525.     if (tvarPtr->errMsg != NULL) {
  1526.     ckfree(tvarPtr->errMsg);
  1527.     tvarPtr->errMsg = NULL;
  1528.     }
  1529.     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1530.  
  1531.     /*
  1532.      * Generate a command to execute by appending list elements
  1533.      * for the two variable names and the operation.  The five
  1534.      * extra characters are for three space, the opcode character,
  1535.      * and the terminating null.
  1536.      */
  1537.  
  1538.     if (name2 == NULL) {
  1539.         name2 = "";
  1540.     }
  1541.     Tcl_DStringInit(&cmd);
  1542.     Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length);
  1543.     Tcl_DStringAppendElement(&cmd, name1);
  1544.     Tcl_DStringAppendElement(&cmd, name2);
  1545.     if (flags & TCL_TRACE_READS) {
  1546.         Tcl_DStringAppend(&cmd, " r", 2);
  1547.     } else if (flags & TCL_TRACE_WRITES) {
  1548.         Tcl_DStringAppend(&cmd, " w", 2);
  1549.     } else if (flags & TCL_TRACE_UNSETS) {
  1550.         Tcl_DStringAppend(&cmd, " u", 2);
  1551.     }
  1552.  
  1553.     /*
  1554.      * Execute the command.  Be careful to save and restore the
  1555.      * result from the interpreter used for the command.
  1556.      */
  1557.  
  1558.     if (interp->freeProc == 0) {
  1559.         dummy.freeProc = (Tcl_FreeProc *) 0;
  1560.         dummy.result = "";
  1561.         Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1562.     } else {
  1563.         dummy.freeProc = interp->freeProc;
  1564.         dummy.result = interp->result;
  1565.         interp->freeProc = (Tcl_FreeProc *) 0;
  1566.     }
  1567.     code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
  1568.     Tcl_DStringFree(&cmd);
  1569.     if (code != TCL_OK) {
  1570.         tvarPtr->errMsg = ckalloc((unsigned) (strlen(interp->result) + 1));
  1571.         strcpy(tvarPtr->errMsg, interp->result);
  1572.         result = tvarPtr->errMsg;
  1573.         Tcl_ResetResult(interp);        /* Must clear error state. */
  1574.     }
  1575.     Tcl_SetResult(interp, dummy.result,
  1576.         (dummy.freeProc == 0) ? TCL_VOLATILE : dummy.freeProc);
  1577.     }
  1578.     if (flags & TCL_TRACE_DESTROYED) {
  1579.     result = NULL;
  1580.     if (tvarPtr->errMsg != NULL) {
  1581.         ckfree(tvarPtr->errMsg);
  1582.     }
  1583.     ckfree((char *) tvarPtr);
  1584.     }
  1585.     return result;
  1586. }
  1587.  
  1588. /*
  1589.  *----------------------------------------------------------------------
  1590.  *
  1591.  * Tcl_WhileCmd --
  1592.  *
  1593.  *    This procedure is invoked to process the "while" Tcl command.
  1594.  *    See the user documentation for details on what it does.
  1595.  *
  1596.  * Results:
  1597.  *    A standard Tcl result.
  1598.  *
  1599.  * Side effects:
  1600.  *    See the user documentation.
  1601.  *
  1602.  *----------------------------------------------------------------------
  1603.  */
  1604.  
  1605.     /* ARGSUSED */
  1606. int
  1607. Tcl_WhileCmd(dummy, interp, argc, argv)
  1608.     ClientData dummy;            /* Not used. */
  1609.     Tcl_Interp *interp;            /* Current interpreter. */
  1610.     int argc;                /* Number of arguments. */
  1611.     char **argv;            /* Argument strings. */
  1612. {
  1613.     int result, value;
  1614.  
  1615.     if (argc != 3) {
  1616.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1617.         argv[0], " test command\"", (char *) NULL);
  1618.     return TCL_ERROR;
  1619.     }
  1620.  
  1621.     while (1) {
  1622.     result = Tcl_ExprBoolean(interp, argv[1], &value);
  1623.     if (result != TCL_OK) {
  1624.         return result;
  1625.     }
  1626.     if (!value) {
  1627.         break;
  1628.     }
  1629.     result = Tcl_Eval(interp, argv[2]);
  1630.     if (result == TCL_CONTINUE) {
  1631.         result = TCL_OK;
  1632.     } else if (result != TCL_OK) {
  1633.         if (result == TCL_ERROR) {
  1634.         char msg[60];
  1635.         sprintf(msg, "\n    (\"while\" body line %d)",
  1636.             interp->errorLine);
  1637.         Tcl_AddErrorInfo(interp, msg);
  1638.         }
  1639.         break;
  1640.     }
  1641.     }
  1642.     if (result == TCL_BREAK) {
  1643.     result = TCL_OK;
  1644.     }
  1645.     if (result == TCL_OK) {
  1646.     Tcl_ResetResult(interp);
  1647.     }
  1648.     return result;
  1649. }
  1650.