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