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