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