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