Logo Search packages:      
Sourcecode: tcl8.3 version File versions  Download package

tclCmdMZ.c

/* 
 * tclCmdMZ.c --
 *
 *    This file contains the top-level command routines for most of
 *    the Tcl built-in commands whose names begin with the letters
 *    M to Z.  It contains only commands in the generic core (i.e.
 *    those that don't depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.c,v 1.26.2.6 2002/03/29 22:42:50 hobbs Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
    int flags;                /* Operations for which Tcl command is
                         * to be invoked. */
    char *errMsg;       /* Error message returned from Tcl command,
                         * or NULL.  Malloc'ed. */
    size_t length;            /* Number of non-NULL chars. in command. */
    char command[4];          /* Space for Tcl command to invoke.  Actual
                         * size will be as large as necessary to
                         * hold command.  This field must be the
                         * last in the structure, so that it can
                         * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * Forward declarations for procedures defined in this file:
 */

static char *           TraceVarProc _ANSI_ARGS_((ClientData clientData,
                      Tcl_Interp *interp, char *name1, char *name2,
                      int flags));

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *    This procedure is invoked to process the "pwd" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_PwdObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    Tcl_DString ds;

    if (objc != 1) {
      Tcl_WrongNumArgs(interp, 1, objv, NULL);
      return TCL_ERROR;
    }

    if (Tcl_GetCwd(interp, &ds) == NULL) {
      return TCL_ERROR;
    }
    Tcl_DStringResult(interp, &ds);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpObjCmd --
 *
 *    This procedure is invoked to process the "regexp" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_RegexpObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    int i, indices, match, about, offset, all, doinline, numMatchesSaved;
    int cflags, eflags, stringLength;
    Tcl_RegExp regExpr;
    Tcl_Obj *objPtr, *resultPtr;
    Tcl_RegExpInfo info;
    static char *options[] = {
      "-all",           "-about",   "-indices", "-inline",
      "-expanded",      "-line",    "-linestop",      "-lineanchor",
      "-nocase",  "-start",   "--",       (char *) NULL
    };
    enum options {
      REGEXP_ALL, REGEXP_ABOUT,     REGEXP_INDICES,   REGEXP_INLINE,
      REGEXP_EXPANDED,REGEXP_LINE,  REGEXP_LINESTOP,REGEXP_LINEANCHOR,
      REGEXP_NOCASE,    REGEXP_START,     REGEXP_LAST
    };

    indices = 0;
    about   = 0;
    cflags  = TCL_REG_ADVANCED;
    eflags  = 0;
    offset  = 0;
    all           = 0;
    doinline      = 0;

    for (i = 1; i < objc; i++) {
      char *name;
      int index;

      name = Tcl_GetString(objv[i]);
      if (name[0] != '-') {
          break;
      }
      if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
            &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch ((enum options) index) {
          case REGEXP_ALL: {
            all = 1;
            break;
          }
          case REGEXP_INDICES: {
            indices = 1;
            break;
          }
          case REGEXP_INLINE: {
            doinline = 1;
            break;
          }
          case REGEXP_NOCASE: {
            cflags |= TCL_REG_NOCASE;
            break;
          }
          case REGEXP_ABOUT: {
            about = 1;
            break;
          }
          case REGEXP_EXPANDED: {
            cflags |= TCL_REG_EXPANDED;
            break;
          }
          case REGEXP_LINE: {
            cflags |= TCL_REG_NEWLINE;
            break;
          }
          case REGEXP_LINESTOP: {
            cflags |= TCL_REG_NLSTOP;
            break;
          }
          case REGEXP_LINEANCHOR: {
            cflags |= TCL_REG_NLANCH;
            break;
          }
          case REGEXP_START: {
            if (++i >= objc) {
                goto endOfForLoop;
            }
            if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
                return TCL_ERROR;
            }
            if (offset < 0) {
                offset = 0;
            }
            break;
          }
          case REGEXP_LAST: {
            i++;
            goto endOfForLoop;
          }
      }
    }

    endOfForLoop:
    if ((objc - i) < (2 - about)) {
      Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
      return TCL_ERROR;
    }
    objc -= i;
    objv += i;

    if (doinline && ((objc - 2) != 0)) {
      /*
       * User requested -inline, but specified match variables - a no-no.
       */
      Tcl_AppendResult(interp, "regexp match variables not allowed",
            " when using -inline", (char *) NULL);
      return TCL_ERROR;
    }

    /*
     * Get the length of the string that we are matching against so
     * we can do the termination test for -all matches.  Do this before
     * getting the regexp to avoid shimmering problems.
     */
    objPtr = objv[1];
    stringLength = Tcl_GetCharLength(objPtr);

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
      return TCL_ERROR;
    }

    if (about) {
      if (TclRegAbout(interp, regExpr) < 0) {
          return TCL_ERROR;
      }
      return TCL_OK;
    }

    if (offset > 0) {
      /*
       * Add flag if using offset (string is part of a larger string),
       * so that "^" won't match.
       */
      eflags |= TCL_REG_NOTBOL;
    }

    objc -= 2;
    objv += 2;
    resultPtr = Tcl_GetObjResult(interp);

    if (doinline) {
      /*
       * Save all the subexpressions, as we will return them as a list
       */
      numMatchesSaved = -1;
    } else {
      /*
       * Save only enough subexpressions for matches we want to keep,
       * expect in the case of -all, where we need to keep at least
       * one to know where to move the offset.
       */
      numMatchesSaved = (objc == 0) ? all : objc;
    }

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match.  If "-all"
     * hasn't been specified then the loop body only gets executed once.
     * We terminate the loop when the starting offset is past the end of the
     * string.
     */

    while (1) {
      match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
            offset /* offset */, numMatchesSaved, eflags);

      if (match < 0) {
          return TCL_ERROR;
      }

      if (match == 0) {
          /*
           * We want to set the value of the intepreter result only when
           * this is the first time through the loop.
           */
          if (all <= 1) {
            /*
             * If inlining, set the interpreter's object result to an
             * empty list, otherwise set it to an integer object w/
             * value 0.
             */
            if (doinline) {
                Tcl_SetListObj(resultPtr, 0, NULL);
            } else {
                Tcl_SetIntObj(resultPtr, 0);
            }
            return TCL_OK;
          }
          break;
      }

      /*
       * If additional variable names have been specified, return
       * index information in those variables.
       */

      Tcl_RegExpGetInfo(regExpr, &info);
      if (doinline) {
          /*
           * It's the number of substitutions, plus one for the matchVar
           * at index 0
           */
          objc = info.nsubs + 1;
      }
      for (i = 0; i < objc; i++) {
          Tcl_Obj *newPtr;

          if (indices) {
            int start, end;
            Tcl_Obj *objs[2];

            /*
             * Only adjust the match area if there was a match for
             * that area.  (Scriptics Bug 4391/SF Bug #219232)
             */
            if (i <= info.nsubs && info.matches[i].start >= 0) {
                start = offset + info.matches[i].start;
                end   = offset + info.matches[i].end;

                /*
                 * Adjust index so it refers to the last character in the
                 * match instead of the first character after the match.
                 */

                if (end >= offset) {
                  end--;
                }
            } else {
                start = -1;
                end   = -1;
            }

            objs[0] = Tcl_NewLongObj(start);
            objs[1] = Tcl_NewLongObj(end);

            newPtr = Tcl_NewListObj(2, objs);
          } else {
            if (i <= info.nsubs) {
                newPtr = Tcl_GetRange(objPtr,
                      offset + info.matches[i].start,
                      offset + info.matches[i].end - 1);
            } else {
                newPtr = Tcl_NewObj();
            }
          }
          if (doinline) {
            if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
                  != TCL_OK) {
                Tcl_DecrRefCount(newPtr);
                return TCL_ERROR;
            }
          } else {
            Tcl_Obj *valuePtr;
            valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
            if (valuePtr == NULL) {
                Tcl_DecrRefCount(newPtr);
                Tcl_AppendResult(interp, "couldn't set variable \"",
                      Tcl_GetString(objv[i]), "\"", (char *) NULL);
                return TCL_ERROR;
            }
          }
      }

      if (all == 0) {
          break;
      }
      /*
       * Adjust the offset to the character just after the last one
       * in the matchVar and increment all to count how many times
       * we are making a match.  We always increment the offset by at least
       * one to prevent endless looping (as in the case:
       * regexp -all {a*} a).  Otherwise, when we match the NULL string at
       * the end of the input string, we will loop indefinately (because the
       * length of the match is 0, so offset never changes).
       */
      if (info.matches[0].end == 0) {
          offset++;
      }
      offset += info.matches[0].end;
      all++;
      eflags |= TCL_REG_NOTBOL;
      if (offset >= stringLength) {
          break;
      }
    }

    /*
     * Set the interpreter's object result to an integer object
     * with value 1 if -all wasn't specified, otherwise it's all-1
     * (the number of times through the while - 1).
     */

    if (!doinline) {
      Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubObjCmd --
 *
 *    This procedure is invoked to process the "regsub" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_RegsubObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    int i, result, cflags, all, wlen, numMatches, offset;
    Tcl_RegExp regExpr;
    Tcl_Obj *resultPtr, *varPtr, *objPtr;
    Tcl_UniChar *wstring;
    char *subspec;

    static char *options[] = {
      "-all",           "-nocase",  "-expanded",
      "-line",    "-linestop",      "-lineanchor",    "-start",
      "--",       NULL
    };
    enum options {
      REGSUB_ALL, REGSUB_NOCASE,    REGSUB_EXPANDED,
      REGSUB_LINE,      REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
      REGSUB_LAST
    };

    cflags = TCL_REG_ADVANCED;
    all = 0;
    offset = 0;

    for (i = 1; i < objc; i++) {
      char *name;
      int index;
      
      name = Tcl_GetString(objv[i]);
      if (name[0] != '-') {
          break;
      }
      if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
            &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch ((enum options) index) {
          case REGSUB_ALL: {
            all = 1;
            break;
          }
          case REGSUB_NOCASE: {
            cflags |= TCL_REG_NOCASE;
            break;
          }
          case REGSUB_EXPANDED: {
            cflags |= TCL_REG_EXPANDED;
            break;
          }
          case REGSUB_LINE: {
            cflags |= TCL_REG_NEWLINE;
            break;
          }
          case REGSUB_LINESTOP: {
            cflags |= TCL_REG_NLSTOP;
            break;
          }
          case REGSUB_LINEANCHOR: {
            cflags |= TCL_REG_NLANCH;
            break;
          }
          case REGSUB_START: {
            if (++i >= objc) {
                goto endOfForLoop;
            }
            if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
                return TCL_ERROR;
            }
            if (offset < 0) {
                offset = 0;
            }
            break;
          }
          case REGSUB_LAST: {
            i++;
            goto endOfForLoop;
          }
      }
    }
    endOfForLoop:
    if (objc - i != 4) {
      Tcl_WrongNumArgs(interp, 1, objv,
            "?switches? exp string subSpec varName");
      return TCL_ERROR;
    }

    objv += i;

    /*
     * Get the length of the string that we are matching before
     * getting the regexp to avoid shimmering problems.
     */

    objPtr = objv[1];
    wlen = Tcl_GetCharLength(objPtr);
    wstring = Tcl_GetUnicode(objPtr);
    subspec = Tcl_GetString(objv[2]);
    varPtr = objv[3];

    regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
    if (regExpr == NULL) {
      return TCL_ERROR;
    }

    result = TCL_OK;
    resultPtr = Tcl_NewObj();
    Tcl_IncrRefCount(resultPtr);

    /*
     * The following loop is to handle multiple matches within the
     * same source string;  each iteration handles one match and its
     * corresponding substitution.  If "-all" hasn't been specified
     * then the loop body only gets executed once.
     */

    numMatches = 0;
    for ( ; offset < wlen; ) {
      int start, end, subStart, subEnd, match;
      char *src, *firstChar;
      char c;
      Tcl_RegExpInfo info;

      /*
       * The flags argument is set if string is part of a larger string,
       * so that "^" won't match.
       */

      match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
            10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0));

      if (match < 0) {
          result = TCL_ERROR;
          goto done;
      }
      if (match == 0) {
          break;
      }
      if ((numMatches == 0) && (offset > 0)) {
          /* Copy the initial portion of the string in if an offset
           * was specified.
           */
          Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
      }
      numMatches++;

      /*
       * Copy the portion of the source string before the match to the
       * result variable.
       */

      Tcl_RegExpGetInfo(regExpr, &info);
      start = info.matches[0].start;
      end = info.matches[0].end;
      Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);

      /*
       * Append the subSpec argument to the variable, making appropriate
       * substitutions.  This code is a bit hairy because of the backslash
       * conventions and because the code saves up ranges of characters in
       * subSpec to reduce the number of calls to Tcl_SetVar.
       */

      src = subspec;
      firstChar = subspec;
      for (c = *src; c != '\0'; src++, c = *src) {
          int index;
    
          if (c == '&') {
            index = 0;
          } else if (c == '\\') {
            c = src[1];
            if ((c >= '0') && (c <= '9')) {
                index = c - '0';
            } else if ((c == '\\') || (c == '&')) {
                Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
                Tcl_AppendToObj(resultPtr, &c, 1);
                firstChar = src + 2;
                src++;
                continue;
            } else {
                continue;
            }
          } else {
            continue;
          }
          if (firstChar != src) {
            Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
          }
          if (index <= info.nsubs) {
            subStart = info.matches[index].start;
            subEnd = info.matches[index].end;
            if ((subStart >= 0) && (subEnd >= 0)) {
                Tcl_AppendUnicodeToObj(resultPtr,
                      wstring + offset + subStart, subEnd - subStart);
            }
          }
          if (*src == '\\') {
            src++;
          }
          firstChar = src + 1;
      }
      if (firstChar != src) {
          Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
      }
      if (end == 0) {
          /*
           * Always consume at least one character of the input string
           * in order to prevent infinite loops.
           */

          Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
          offset++;
      }
      offset += end;
      if (!all) {
          break;
      }
    }

    /*
     * Copy the portion of the source string after the last match to the
     * result variable.
     */

    if (numMatches == 0) {
      /*
       * On zero matches, just ignore the offset, since it shouldn't
       * matter to us in this case, and the user may have skewed it.
       */
      Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen);
    } else if (offset < wlen) {
      Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
    }
    if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) {
      Tcl_AppendResult(interp, "couldn't set variable \"",
            Tcl_GetString(varPtr), "\"", (char *) NULL);
      result = TCL_ERROR;
    } else {
      /*
       * Set the interpreter's object result to an integer object holding the
       * number of matches. 
       */
      
      Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
    }

    done:
    Tcl_DecrRefCount(resultPtr);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameObjCmd --
 *
 *    This procedure is invoked to process the "rename" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Arbitrary value passed to the command. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    char *oldName, *newName;
    
    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
      return TCL_ERROR;
    }

    oldName = Tcl_GetString(objv[1]);
    newName = Tcl_GetString(objv[2]);
    return TclRenameCommand(interp, oldName, newName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReturnObjCmd --
 *
 *    This object-based procedure is invoked to process the "return" Tcl
 *    command. See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_ReturnObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    int optionLen, argLen, code, result;

    if (iPtr->errorInfo != NULL) {
      ckfree(iPtr->errorInfo);
      iPtr->errorInfo = NULL;
    }
    if (iPtr->errorCode != NULL) {
      ckfree(iPtr->errorCode);
      iPtr->errorCode = NULL;
    }
    code = TCL_OK;
    
    for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
      char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
      char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
      
      if (strcmp(option, "-code") == 0) {
          register int c = arg[0];
          if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
            code = TCL_OK;
          } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
            code = TCL_ERROR;
          } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
            code = TCL_RETURN;
          } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
            code = TCL_BREAK;
          } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
            code = TCL_CONTINUE;
          } else {
            result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
                    &code);
            if (result != TCL_OK) {
                Tcl_ResetResult(interp);
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                      "bad completion code \"",
                      Tcl_GetString(objv[1]),
                      "\": must be ok, error, return, break, ",
                      "continue, or an integer", (char *) NULL);
                return result;
            }
          }
      } else if (strcmp(option, "-errorinfo") == 0) {
          iPtr->errorInfo =
            (char *) ckalloc((unsigned) (strlen(arg) + 1));
          strcpy(iPtr->errorInfo, arg);
      } else if (strcmp(option, "-errorcode") == 0) {
          iPtr->errorCode =
            (char *) ckalloc((unsigned) (strlen(arg) + 1));
          strcpy(iPtr->errorCode, arg);
      } else {
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                "bad option \"", option,
                "\": must be -code, -errorcode, or -errorinfo",
                (char *) NULL);
          return TCL_ERROR;
      }
    }
    
    if (objc == 1) {
      /*
       * Set the interpreter's object result. An inline version of
       * Tcl_SetObjResult.
       */

      Tcl_SetObjResult(interp, objv[0]);
    }
    iPtr->returnCode = code;
    return TCL_RETURN;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SourceObjCmd --
 *
 *    This procedure is invoked to process the "source" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    char *bytes;
    int result;
    
    if (objc != 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "fileName");
      return TCL_ERROR;
    }

    bytes = Tcl_GetString(objv[1]);
    result = Tcl_EvalFile(interp, bytes);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitObjCmd --
 *
 *    This procedure is invoked to process the "split" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    Tcl_UniChar ch;
    int len;
    char *splitChars, *string, *end;
    int splitCharLen, stringLen;
    Tcl_Obj *listPtr, *objPtr;

    if (objc == 2) {
      splitChars = " \n\t\r";
      splitCharLen = 4;
    } else if (objc == 3) {
      splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
    } else {
      Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
      return TCL_ERROR;
    }

    string = Tcl_GetStringFromObj(objv[1], &stringLen);
    end = string + stringLen;
    listPtr = Tcl_GetObjResult(interp);
    
    if (stringLen == 0) {
      /*
       * Do nothing.
       */
    } else if (splitCharLen == 0) {
      Tcl_HashTable charReuseTable;
      Tcl_HashEntry *hPtr;
      int isNew;

      /*
       * Handle the special case of splitting on every character.
       *
       * Uses a hash table to ensure that each kind of character has
       * only one Tcl_Obj instance (multiply-referenced) in the
       * final list.  This is a *major* win when splitting on a long
       * string (especially in the megabyte range!) - DKF
       */

      Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
      for ( ; string < end; string += len) {
          len = Tcl_UtfToUniChar(string, &ch);
          /* Assume Tcl_UniChar is an integral type... */
          hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
          if (isNew) {
            objPtr = Tcl_NewStringObj(string, len);
            /* Don't need to fiddle with refcount... */
            Tcl_SetHashValue(hPtr, (ClientData) objPtr);
          } else {
            objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
          }
          Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
      }
      Tcl_DeleteHashTable(&charReuseTable);
    } else {
      char *element, *p, *splitEnd;
      int splitLen;
      Tcl_UniChar splitChar;
      
      /*
       * Normal case: split on any of a given set of characters.
       * Discard instances of the split characters.
       */

      splitEnd = splitChars + splitCharLen;

      for (element = string; string < end; string += len) {
          len = Tcl_UtfToUniChar(string, &ch);
          for (p = splitChars; p < splitEnd; p += splitLen) {
            splitLen = Tcl_UtfToUniChar(p, &splitChar);
            if (ch == splitChar) {
                objPtr = Tcl_NewStringObj(element, string - element);
                Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
                element = string + len;
                break;
            }
          }
      }
      objPtr = Tcl_NewStringObj(element, string - element);
      Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringObjCmd --
 *
 *    This procedure is invoked to process the "string" Tcl command.
 *    See the user documentation for details on what it does.  Note
 *    that this command only functions correctly on properly formed
 *    Tcl UTF strings.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    int index, left, right;
    Tcl_Obj *resultPtr;
    char *string1, *string2;
    int length1, length2;
    static char *options[] = {
      "bytelength",     "compare",  "equal",    "first",
      "index",    "is",       "last",           "length",
      "map",            "match",    "range",    "repeat",
      "replace",  "tolower",  "toupper",  "totitle",
      "trim",           "trimleft", "trimright",
      "wordend",  "wordstart",      (char *) NULL
    };
    enum options {
      STR_BYTELENGTH,   STR_COMPARE,      STR_EQUAL,  STR_FIRST,
      STR_INDEX,  STR_IS,           STR_LAST,   STR_LENGTH,
      STR_MAP,    STR_MATCH,  STR_RANGE,  STR_REPEAT,
      STR_REPLACE,      STR_TOLOWER,      STR_TOUPPER,      STR_TOTITLE,
      STR_TRIM,   STR_TRIMLEFT,     STR_TRIMRIGHT,
      STR_WORDEND,      STR_WORDSTART
    };        

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
      return TCL_ERROR;
    }
    
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
          &index) != TCL_OK) {
      return TCL_ERROR;
    }

    resultPtr = Tcl_GetObjResult(interp);
    switch ((enum options) index) {
      case STR_EQUAL:
      case STR_COMPARE: {
          int i, match, length, nocase = 0, reqlength = -1;

          if (objc < 4 || objc > 7) {
          str_cmp_args:
              Tcl_WrongNumArgs(interp, 2, objv,
                         "?-nocase? ?-length int? string1 string2");
            return TCL_ERROR;
          }

          for (i = 2; i < objc-2; i++) {
            string2 = Tcl_GetStringFromObj(objv[i], &length2);
            if ((length2 > 1)
                  && strncmp(string2, "-nocase", (size_t)length2) == 0) {
                nocase = 1;
            } else if ((length2 > 1)
                  && strncmp(string2, "-length", (size_t)length2) == 0) {
                if (i+1 >= objc-2) {
                  goto str_cmp_args;
                }
                if (Tcl_GetIntFromObj(interp, objv[++i],
                      &reqlength) != TCL_OK) {
                  return TCL_ERROR;
                }
            } else {
                Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                      string2, "\": must be -nocase or -length",
                      (char *) NULL);
                return TCL_ERROR;
            }
          }

          string1 = Tcl_GetStringFromObj(objv[objc-2], &length1);
          string2 = Tcl_GetStringFromObj(objv[objc-1], &length2);
          /*
           * This is the min length IN BYTES of the two strings
           */
          length = (length1 < length2) ? length1 : length2;

          if (reqlength == 0) {
            /*
             * Anything matches at 0 chars, right?
             */

            match = 0;
          } else if (nocase || ((reqlength > 0) && (reqlength <= length))) {
            /*
             * with -nocase or -length we have to check true char length
             * as it could be smaller than expected
             */

            length1 = Tcl_NumUtfChars(string1, length1);
            length2 = Tcl_NumUtfChars(string2, length2);
            length = (length1 < length2) ? length1 : length2;

            /*
             * Do the reqlength check again, against 0 as well for
             * the benfit of nocase
             */

            if ((reqlength > 0) && (reqlength < length)) {
                length = reqlength;
            } else if (reqlength < 0) {
                /*
                 * The requested length is negative, so we ignore it by
                 * setting it to the longer of the two lengths.
                 */

                reqlength = (length1 > length2) ? length1 : length2;
            }
            if (nocase) {
                match = Tcl_UtfNcasecmp(string1, string2,
                      (unsigned) length);
            } else {
                match = Tcl_UtfNcmp(string1, string2, (unsigned) length);
            }
            if ((match == 0) && (reqlength > length)) {
                match = length1 - length2;
            }
          } else {
            match = memcmp(string1, string2, (unsigned) length);
            if (match == 0) {
                match = length1 - length2;
            }
          }

          if ((enum options) index == STR_EQUAL) {
            Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
          } else {
            Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
                                (match < 0) ? -1 : 0));
          }
          break;
      }
      case STR_FIRST: {
          register char *p, *end;
          int match, utflen, start;

          if (objc < 4 || objc > 5) {
              Tcl_WrongNumArgs(interp, 2, objv,
                         "string1 string2 ?startIndex?");
            return TCL_ERROR;
          }

          /*
           * This algorithm fails on improperly formed UTF strings.
           * We are searching string2 for the sequence string1.
           */

          match = -1;
          start = 0;
          utflen = -1;
          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          string2 = Tcl_GetStringFromObj(objv[3], &length2);

          if (objc == 5) {
            /*
             * If a startIndex is specified, we will need to fast forward
             * to that point in the string before we think about a match
             */
            utflen = Tcl_NumUtfChars(string2, length2);
            if (TclGetIntForIndex(interp, objv[4], utflen-1,
                              &start) != TCL_OK) {
                return TCL_ERROR;
            }
            if (start >= utflen) {
                goto str_first_done;
            } else if (start > 0) {
                if (length2 == utflen) {
                  /* no unicode chars */
                  string2 += start;
                  length2 -= start;
                } else {
                  char *s = Tcl_UtfAtIndex(string2, start);
                  length2 -= s - string2;
                  string2 = s;
                }
            }
          }

          if (length1 > 0) {
            end = string2 + length2 - length1 + 1;
            for (p = string2;  p < end;  p++) {
                /*
                 * Scan forward to find the first character.
                 */

                p = memchr(p, *string1, (unsigned) (end - p));
                if (p == NULL) {
                  break;
                }
                if (memcmp(string1, p, (unsigned) length1) == 0) {
                  match = p - string2;
                  break;
                }
            }
          }

          /*
           * Compute the character index of the matching string by
           * counting the number of characters before the match.
           */
      str_first_done:
          if (match != -1) {
            if (objc == 4) {
                match = Tcl_NumUtfChars(string2, match);
            } else if (length2 == utflen) {
                /* no unicode chars */
                match += start;
            } else {
                match = start + Tcl_NumUtfChars(string2, match);
            }
          }
          Tcl_SetIntObj(resultPtr, match);
          break;
      }
      case STR_INDEX: {
          if (objc != 4) {
              Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
            return TCL_ERROR;
          }

          /*
           * If we have a ByteArray object, avoid indexing in the
           * Utf string since the byte array contains one byte per
           * character.  Otherwise, use the Unicode string rep to
           * get the index'th char.
           */

          if (objv[2]->typePtr == &tclByteArrayType) {
            string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);

            if (TclGetIntForIndex(interp, objv[3], length1 - 1,
                  &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if ((index >= 0) && (index < length1)) {
                Tcl_SetByteArrayObj(resultPtr,
                      (unsigned char *)(&string1[index]), 1);
            }
          } else {
            /*
             * Get Unicode char length to calulate what 'end' means.
             */
            length1 = Tcl_GetCharLength(objv[2]);

            if (TclGetIntForIndex(interp, objv[3], length1 - 1,
                  &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if ((index >= 0) && (index < length1)) {
                char buf[TCL_UTF_MAX];
                Tcl_UniChar ch;

                ch      = Tcl_GetUniChar(objv[2], index);
                length1 = Tcl_UniCharToUtf(ch, buf);
                Tcl_SetStringObj(resultPtr, buf, length1);
            }
          }
          break;
      }
      case STR_IS: {
          char *end;
          Tcl_UniChar ch;

            /*
           * The UniChar comparison function
           */

          int (*chcomp)_ANSI_ARGS_((int)) = NULL; 
          int i, failat = 0, result = 1, strict = 0;
          Tcl_Obj *objPtr, *failVarObj = NULL;

          static char *isOptions[] = {
            "alnum",    "alpha",    "ascii",    "control",
            "boolean",  "digit",    "double",   "false",
            "graph",    "integer",  "lower",    "print",
            "punct",    "space",    "true",           "upper",
            "wordchar", "xdigit",   (char *) NULL
          };
          enum isOptions {
            STR_IS_ALNUM,     STR_IS_ALPHA,     STR_IS_ASCII,     STR_IS_CONTROL,
            STR_IS_BOOL,      STR_IS_DIGIT,     STR_IS_DOUBLE,    STR_IS_FALSE,
            STR_IS_GRAPH,     STR_IS_INT, STR_IS_LOWER,     STR_IS_PRINT,
            STR_IS_PUNCT,     STR_IS_SPACE,     STR_IS_TRUE,      STR_IS_UPPER,
            STR_IS_WORD,      STR_IS_XDIGIT
          };

          if (objc < 4 || objc > 7) {
            Tcl_WrongNumArgs(interp, 2, objv,
                         "class ?-strict? ?-failindex var? str");
            return TCL_ERROR;
          }
          if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
                            &index) != TCL_OK) {
            return TCL_ERROR;
          }
          if (objc != 4) {
            for (i = 3; i < objc-1; i++) {
                string2 = Tcl_GetStringFromObj(objv[i], &length2);
                if ((length2 > 1) &&
                  strncmp(string2, "-strict", (size_t) length2) == 0) {
                  strict = 1;
                } else if ((length2 > 1) &&
                      strncmp(string2, "-failindex",
                            (size_t) length2) == 0) {
                  if (i+1 >= objc-1) {
                      Tcl_WrongNumArgs(interp, 3, objv,
                                   "?-strict? ?-failindex var? str");
                      return TCL_ERROR;
                  }
                  failVarObj = objv[++i];
                } else {
                  Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                        string2, "\": must be -strict or -failindex",
                        (char *) NULL);
                  return TCL_ERROR;
                }
            }
          }

          /*
           * We get the objPtr so that we can short-cut for some classes
           * by checking the object type (int and double), but we need
           * the string otherwise, because we don't want any conversion
           * of type occuring (as, for example, Tcl_Get*FromObj would do
           */
          objPtr = objv[objc-1];
          string1 = Tcl_GetStringFromObj(objPtr, &length1);
          if (length1 == 0) {
            if (strict) {
                result = 0;
            }
            goto str_is_done;
          }
          end = string1 + length1;

          /*
           * When entering here, result == 1 and failat == 0
           */
          switch ((enum isOptions) index) {
            case STR_IS_ALNUM:
                chcomp = Tcl_UniCharIsAlnum;
                break;
            case STR_IS_ALPHA:
                chcomp = Tcl_UniCharIsAlpha;
                break;
            case STR_IS_ASCII:
                for (; string1 < end; string1++, failat++) {
                  /*
                   * This is a valid check in unicode, because all
                   * bytes < 0xC0 are single byte chars (but isascii
                   * limits that def'n to 0x80).
                   */
                  if (*((unsigned char *)string1) >= 0x80) {
                      result = 0;
                      break;
                  }
                }
                break;
            case STR_IS_BOOL:
            case STR_IS_TRUE:
            case STR_IS_FALSE:
                if (objPtr->typePtr == &tclBooleanType) {
                  if ((((enum isOptions) index == STR_IS_TRUE) &&
                       objPtr->internalRep.longValue == 0) ||
                      (((enum isOptions) index == STR_IS_FALSE) &&
                       objPtr->internalRep.longValue != 0)) {
                      result = 0;
                  }
                } else if ((Tcl_GetBoolean(NULL, string1, &i)
                        == TCL_ERROR) ||
                         (((enum isOptions) index == STR_IS_TRUE) &&
                        i == 0) ||
                         (((enum isOptions) index == STR_IS_FALSE) &&
                        i != 0)) {
                  result = 0;
                }
                break;
            case STR_IS_CONTROL:
                chcomp = Tcl_UniCharIsControl;
                break;
            case STR_IS_DIGIT:
                chcomp = Tcl_UniCharIsDigit;
                break;
            case STR_IS_DOUBLE: {
                char *stop;

                if ((objPtr->typePtr == &tclDoubleType) ||
                  (objPtr->typePtr == &tclIntType)) {
                  break;
                }
                /*
                 * This is adapted from Tcl_GetDouble
                 *
                 * The danger in this function is that
                 * "12345678901234567890" is an acceptable 'double',
                 * but will later be interp'd as an int by something
                 * like [expr].  Therefore, we check to see if it looks
                 * like an int, and if so we do a range check on it.
                 * If strtoul gets to the end, we know we either
                 * received an acceptable int, or over/underflow
                 */
                if (TclLooksLikeInt(string1, length1)) {
                  errno = 0;
                  strtoul(string1, &stop, 0);
                  if (stop == end) {
                      if (errno == ERANGE) {
                        result = 0;
                        failat = -1;
                      }
                      break;
                  }
                }
                errno = 0;
                strtod(string1, &stop); /* INTL: Tcl source. */
                if (errno == ERANGE) {
                  /*
                   * if (errno == ERANGE), then it was an over/underflow
                   * problem, but in this method, we only want to know
                   * yes or no, so bad flow returns 0 (false) and sets
                   * the failVarObj to the string length.
                   */
                  result = 0;
                  failat = -1;
                } else if (stop == string1) {
                  /*
                   * In this case, nothing like a number was found
                   */
                  result = 0;
                  failat = 0;
                } else {
                  /*
                   * Assume we sucked up one char per byte
                   * and then we go onto SPACE, since we are
                   * allowed trailing whitespace
                   */
                  failat = stop - string1;
                  string1 = stop;
                  chcomp = Tcl_UniCharIsSpace;
                }
                break;
            }
            case STR_IS_GRAPH:
                chcomp = Tcl_UniCharIsGraph;
                break;
            case STR_IS_INT: {
                char *stop;

                if ((objPtr->typePtr == &tclIntType) ||
                  (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
                  break;
                }
                /*
                 * Like STR_IS_DOUBLE, but we use strtoul.
                 * Since Tcl_GetInt already failed, we set result to 0.
                 */
                result = 0;
                errno = 0;
                strtoul(string1, &stop, 0); /* INTL: Tcl source. */
                if (errno == ERANGE) {
                  /*
                   * if (errno == ERANGE), then it was an over/underflow
                   * problem, but in this method, we only want to know
                   * yes or no, so bad flow returns 0 (false) and sets
                   * the failVarObj to the string length.
                   */
                  failat = -1;
                } else if (stop == string1) {
                  /*
                   * In this case, nothing like a number was found
                   */
                  failat = 0;
                } else {
                  /*
                   * Assume we sucked up one char per byte
                   * and then we go onto SPACE, since we are
                   * allowed trailing whitespace
                   */
                  failat = stop - string1;
                  string1 = stop;
                  chcomp = Tcl_UniCharIsSpace;
                }
                break;
            }
            case STR_IS_LOWER:
                chcomp = Tcl_UniCharIsLower;
                break;
            case STR_IS_PRINT:
                chcomp = Tcl_UniCharIsPrint;
                break;
            case STR_IS_PUNCT:
                chcomp = Tcl_UniCharIsPunct;
                break;
            case STR_IS_SPACE:
                chcomp = Tcl_UniCharIsSpace;
                break;
            case STR_IS_UPPER:
                chcomp = Tcl_UniCharIsUpper;
                break;
            case STR_IS_WORD:
                chcomp = Tcl_UniCharIsWordChar;
                break;
            case STR_IS_XDIGIT: {
                for (; string1 < end; string1++, failat++) {
                  /* INTL: We assume unicode is bad for this class */
                  if ((*((unsigned char *)string1) >= 0xC0) ||
                      !isxdigit(*(unsigned char *)string1)) {
                      result = 0;
                      break;
                  }
                }
                break;
            }
          }
          if (chcomp != NULL) {
            for (; string1 < end; string1 += length2, failat++) {
                length2 = Tcl_UtfToUniChar(string1, &ch);
                if (!chcomp(ch)) {
                  result = 0;
                  break;
                }
            }
          }
      str_is_done:
          /*
           * Only set the failVarObj when we will return 0
           * and we have indicated a valid fail index (>= 0)
           */
          if ((result == 0) && (failVarObj != NULL) &&
            Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
                         TCL_LEAVE_ERR_MSG) == NULL) {
            return TCL_ERROR;
          }
          Tcl_SetBooleanObj(resultPtr, result);
          break;
      }
      case STR_LAST: {
          register char *p;
          int match, utflen, start;

          if (objc < 4 || objc > 5) {
              Tcl_WrongNumArgs(interp, 2, objv,
                         "string1 string2 ?startIndex?");
            return TCL_ERROR;
          }

          /*
           * This algorithm fails on improperly formed UTF strings.
           */

          match = -1;
          start = 0;
          utflen = -1;
          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          string2 = Tcl_GetStringFromObj(objv[3], &length2);

          if (objc == 5) {
            /*
             * If a startIndex is specified, we will need to restrict
             * the string range to that char index in the string
             */
            utflen = Tcl_NumUtfChars(string2, length2);
            if (TclGetIntForIndex(interp, objv[4], utflen-1,
                              &start) != TCL_OK) {
                return TCL_ERROR;
            }
            if (start < 0) {
                goto str_last_done;
            } else if (start < utflen) {
                if (length2 == utflen) {
                  /* no unicode chars */
                  p = string2 + start + 1 - length1;
                } else {
                  p = Tcl_UtfAtIndex(string2, start+1) - length1;
                }
            } else {
                p = string2 + length2 - length1;
            }
          } else {
            p = string2 + length2 - length1;
          }

          if (length1 > 0) {
            for (;  p >= string2;  p--) {
                /*
                 * Scan backwards to find the first character.
                 */

                while ((p != string2) && (*p != *string1)) {
                  p--;
                }
                if (memcmp(string1, p, (unsigned) length1) == 0) {
                  match = p - string2;
                  break;
                }
            }
          }

          /*
           * Compute the character index of the matching string by counting
           * the number of characters before the match.
           */
      str_last_done:
          if (match != -1) {
            if ((objc == 4) || (length2 != utflen)) {
                /* only check when we've got unicode chars */
                match = Tcl_NumUtfChars(string2, match);
            }
          }
          Tcl_SetIntObj(resultPtr, match);
          break;
      }
      case STR_BYTELENGTH:
      case STR_LENGTH: {
          if (objc != 3) {
              Tcl_WrongNumArgs(interp, 2, objv, "string");
            return TCL_ERROR;
          }

          if ((enum options) index == STR_BYTELENGTH) {
            (void) Tcl_GetStringFromObj(objv[2], &length1);
          } else {
            /*
             * If we have a ByteArray object, avoid recomputing the
             * string since the byte array contains one byte per
             * character.  Otherwise, use the Unicode string rep to
             * calculate the length.
             */

            if (objv[2]->typePtr == &tclByteArrayType) {
                (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
            } else {
                length1 = Tcl_GetCharLength(objv[2]);
            }
          }
          Tcl_SetIntObj(resultPtr, length1);
          break;
      }
      case STR_MAP: {
          int uselen, mapElemc, len, nocase = 0;
          Tcl_Obj **mapElemv;
          char *end;
          Tcl_UniChar ch;
          int (*str_comp_fn)();

          if (objc < 4 || objc > 5) {
              Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
            return TCL_ERROR;
          }

          if (objc == 5) {
            string2 = Tcl_GetStringFromObj(objv[2], &length2);
            if ((length2 > 1) &&
                strncmp(string2, "-nocase", (size_t) length2) == 0) {
                nocase = 1;
            } else {
                Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                                 string2, "\": must be -nocase",
                                 (char *) NULL);
                return TCL_ERROR;
            }
          }

          if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
                               &mapElemv) != TCL_OK) {
            return TCL_ERROR;
          }
          if (mapElemc == 0) {
            /*
             * empty charMap, just return whatever string was given
             */
            Tcl_SetObjResult(interp, objv[objc-1]);
            return TCL_OK;
          } else if (mapElemc & 1) {
            /*
             * The charMap must be an even number of key/value items
             */
            Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
            return TCL_ERROR;
          }
          string1 = Tcl_GetStringFromObj(objv[objc-1], &length1);
          if (length1 == 0) {
            break;
          }
          end = string1 + length1;

          if (nocase) {
            length1 = Tcl_NumUtfChars(string1, length1);
            str_comp_fn = Tcl_UtfNcasecmp;
          } else {
            str_comp_fn = memcmp;
          }

          for ( ; string1 < end; string1 += len) {
            len = Tcl_UtfToUniChar(string1, &ch);
            for (index = 0; index < mapElemc; index +=2) {
                /*
                 * Get the key string to match on
                 */
                string2 = Tcl_GetStringFromObj(mapElemv[index],
                                       &length2);
                if (nocase) {
                  uselen = Tcl_NumUtfChars(string2, length2);
                } else {
                  uselen = length2;
                }
                if ((uselen > 0) && (uselen <= length1) &&
                  (str_comp_fn(string2, string1, uselen) == 0)) {
                  /*
                   * Adjust len to be full length of matched string
                   * it has to be the BYTE length
                   */
                  len = length2;
                  /*
                   * Change string2 and length2 to the map value
                   */
                  string2 = Tcl_GetStringFromObj(mapElemv[index+1],
                                           &length2);
                  Tcl_AppendToObj(resultPtr, string2, length2);
                  break;
                }
            }
            if (index == mapElemc) {
                /*
                 * No match was found, put the char onto result
                 */
                Tcl_AppendToObj(resultPtr, string1, len);
            }
            /*
             * in nocase, length1 is in chars
             * otherwise it is in bytes
             */
            if (nocase) {
                length1--;
            } else {
                length1 -= len;
            }
          }
          break;
      }
      case STR_MATCH: {
          int nocase = 0;

          if (objc < 4 || objc > 5) {
              Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
            return TCL_ERROR;
          }

          if (objc == 5) {
            string2 = Tcl_GetStringFromObj(objv[2], &length2);
            if ((length2 > 1) &&
                strncmp(string2, "-nocase", (size_t) length2) == 0) {
                nocase = 1;
            } else {
                Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                                 string2, "\": must be -nocase",
                                 (char *) NULL);
                return TCL_ERROR;
            }
          }

          Tcl_SetBooleanObj(resultPtr,
                        Tcl_StringCaseMatch(Tcl_GetString(objv[objc-1]),
                                      Tcl_GetString(objv[objc-2]),
                                      nocase));
          break;
      }
      case STR_RANGE: {
          int first, last;

          if (objc != 5) {
              Tcl_WrongNumArgs(interp, 2, objv, "string first last");
            return TCL_ERROR;
          }

          /*
           * If we have a ByteArray object, avoid indexing in the
           * Utf string since the byte array contains one byte per
           * character.  Otherwise, use the Unicode string rep to
           * get the range.
           */

          if (objv[2]->typePtr == &tclByteArrayType) {

            string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);

            if (TclGetIntForIndex(interp, objv[3], length1 - 1,
                  &first) != TCL_OK) {
                return TCL_ERROR;
            }
            if (TclGetIntForIndex(interp, objv[4], length1 - 1,
                  &last) != TCL_OK) {
                return TCL_ERROR;
            }
            if (first < 0) {
                first = 0;
            }
            if (last >= length1 - 1) {
                last = length1 - 1;
            }
            if (last >= first) {
                int numBytes = last - first + 1;
                resultPtr = Tcl_NewByteArrayObj(
                        (unsigned char *) &string1[first], numBytes);
                Tcl_SetObjResult(interp, resultPtr);
            }
          } else {
            string1 = Tcl_GetStringFromObj(objv[2], &length1);
            
            /*
             * Convert to Unicode internal rep to calulate length and
             * create a result object.
             */

            length2 = Tcl_GetCharLength(objv[2]) - 1;
    
            if (TclGetIntForIndex(interp, objv[3], length2,
                  &first) != TCL_OK) {
                return TCL_ERROR;
            }
            if (TclGetIntForIndex(interp, objv[4], length2,
                  &last) != TCL_OK) {
                return TCL_ERROR;
            }
            if (first < 0) {
                first = 0;
            }
            if (last >= length2) {
                last = length2;
            }
            if (last >= first) {
                resultPtr = Tcl_GetRange(objv[2], first, last);
                Tcl_SetObjResult(interp, resultPtr);
            }
          }
          break;
      }
      case STR_REPEAT: {
          int count;

          if (objc != 4) {
            Tcl_WrongNumArgs(interp, 2, objv, "string count");
            return TCL_ERROR;
          }

          if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
            return TCL_ERROR;
          }

          if (count == 1) {
            Tcl_SetObjResult(interp, objv[2]);
          } else if (count > 1) {
          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          if (length1 > 0) {
                /*
                 * Only build up a string that has data.  Instead of
                 * building it up with repeated appends, we just allocate
                 * the necessary space once and copy the string value in.
                 */
                length2       = length1 * count;
                /*
                 * Include space for the NULL
                 */
                string2       = (char *) ckalloc((size_t) length2+1);
            for (index = 0; index < count; index++) {
                  memcpy(string2 + (length1 * index), string1,
                        (size_t) length1);
            }
                string2[length2]    = '\0';
                /*
                 * We have to directly assign this instead of using
                 * Tcl_SetStringObj (and indirectly TclInitStringRep)
                 * because that makes another copy of the data.
                 */
                resultPtr           = Tcl_NewObj();
                resultPtr->bytes    = string2;
                resultPtr->length   = length2;
                Tcl_SetObjResult(interp, resultPtr);
          }
          }
          break;
      }
      case STR_REPLACE: {
          int first, last;

          if (objc < 5 || objc > 6) {
              Tcl_WrongNumArgs(interp, 2, objv,
                         "string first last ?string?");
            return TCL_ERROR;
          }

          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          length1 = Tcl_NumUtfChars(string1, length1) - 1;
          if (TclGetIntForIndex(interp, objv[3], length1,
                          &first) != TCL_OK) {
            return TCL_ERROR;
          }
          if (TclGetIntForIndex(interp, objv[4], length1,
                &last) != TCL_OK) {
            return TCL_ERROR;
          }
          if ((last < first) || (first > length1) || (last < 0)) {
            Tcl_SetObjResult(interp, objv[2]);
          } else {
            char *start, *end;

            if (first < 0) {
                first = 0;
            }
            start = Tcl_UtfAtIndex(string1, first);
            end = Tcl_UtfAtIndex(start, ((last > length1) ? length1 : last)
                             - first + 1);
              Tcl_SetStringObj(resultPtr, string1, start - string1);
            if (objc == 6) {
                Tcl_AppendObjToObj(resultPtr, objv[5]);
            }
            if (last < length1) {
                Tcl_AppendToObj(resultPtr, end, -1);
            }
          }
          break;
      }
      case STR_TOLOWER:
      case STR_TOUPPER:
      case STR_TOTITLE:
          if (objc < 3 || objc > 5) {
              Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
            return TCL_ERROR;
          }

          string1 = Tcl_GetStringFromObj(objv[2], &length1);

          if (objc == 3) {
            /*
             * Since the result object is not a shared object, it is
             * safe to copy the string into the result and do the
             * conversion in place.  The conversion may change the length
             * of the string, so reset the length after conversion.
             */

            Tcl_SetStringObj(resultPtr, string1, length1);
            if ((enum options) index == STR_TOLOWER) {
                length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
            } else if ((enum options) index == STR_TOUPPER) {
                length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
            } else {
                length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
            }
            Tcl_SetObjLength(resultPtr, length1);
          } else {
            int first, last;
            char *start, *end;

            length1 = Tcl_NumUtfChars(string1, length1) - 1;
            if (TclGetIntForIndex(interp, objv[3], length1,
                              &first) != TCL_OK) {
                return TCL_ERROR;
            }
            if (first < 0) {
                first = 0;
            }
            last = first;
            if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
                                          &last) != TCL_OK)) {
                return TCL_ERROR;
            }
            if (last >= length1) {
                last = length1;
            }
            if (last < first) {
                Tcl_SetObjResult(interp, objv[2]);
                break;
            }
            start = Tcl_UtfAtIndex(string1, first);
            end = Tcl_UtfAtIndex(start, last - first + 1);
            length2 = end-start;
            string2 = ckalloc((size_t) length2+1);
            memcpy(string2, start, (size_t) length2);
            string2[length2] = '\0';
            if ((enum options) index == STR_TOLOWER) {
                length2 = Tcl_UtfToLower(string2);
            } else if ((enum options) index == STR_TOUPPER) {
                length2 = Tcl_UtfToUpper(string2);
            } else {
                length2 = Tcl_UtfToTitle(string2);
            }
            Tcl_SetStringObj(resultPtr, string1, start - string1);
            Tcl_AppendToObj(resultPtr, string2, length2);
            Tcl_AppendToObj(resultPtr, end, -1);
            ckfree(string2);
          }
          break;

      case STR_TRIM: {
          Tcl_UniChar ch, trim;
          register char *p, *end;
          char *check, *checkEnd;
          int offset;

          left = 1;
          right = 1;

          dotrim:
          if (objc == 4) {
            string2 = Tcl_GetStringFromObj(objv[3], &length2);
          } else if (objc == 3) {
            string2 = " \t\n\r";
            length2 = strlen(string2);
          } else {
              Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
            return TCL_ERROR;
          }
          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          checkEnd = string2 + length2;

          if (left) {
            end = string1 + length1;
            /*
             * The outer loop iterates over the string.  The inner
             * loop iterates over the trim characters.  The loops
             * terminate as soon as a non-trim character is discovered
             * and string1 is left pointing at the first non-trim
             * character.
             */

            for (p = string1; p < end; p += offset) {
                offset = Tcl_UtfToUniChar(p, &ch);
                
                for (check = string2; ; ) {
                  if (check >= checkEnd) {
                      p = end;
                      break;
                  }
                  check += Tcl_UtfToUniChar(check, &trim);
                  if (ch == trim) {
                      length1 -= offset;
                      string1 += offset;
                      break;
                  }
                }
            }
          }
          if (right) {
              end = string1;

            /*
             * The outer loop iterates over the string.  The inner
             * loop iterates over the trim characters.  The loops
             * terminate as soon as a non-trim character is discovered
             * and length1 marks the last non-trim character.
             */

            for (p = string1 + length1; p > end; ) {
                p = Tcl_UtfPrev(p, string1);
                offset = Tcl_UtfToUniChar(p, &ch);
                for (check = string2; ; ) {
                    if (check >= checkEnd) {
                      p = end;
                      break;
                  }
                  check += Tcl_UtfToUniChar(check, &trim);
                  if (ch == trim) {
                      length1 -= offset;
                      break;
                  }
                }
            }
          }
          Tcl_SetStringObj(resultPtr, string1, length1);
          break;
      }
      case STR_TRIMLEFT: {
          left = 1;
          right = 0;
          goto dotrim;
      }
      case STR_TRIMRIGHT: {
          left = 0;
          right = 1;
          goto dotrim;
      }
      case STR_WORDEND: {
          int cur;
          Tcl_UniChar ch;
          char *p, *end;
          int numChars;
          
          if (objc != 4) {
              Tcl_WrongNumArgs(interp, 2, objv, "string index");
            return TCL_ERROR;
          }

          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          numChars = Tcl_NumUtfChars(string1, length1);
          if (TclGetIntForIndex(interp, objv[3], numChars-1,
                          &index) != TCL_OK) {
            return TCL_ERROR;
          }
          if (index < 0) {
            index = 0;
          }
          if (index < numChars) {
            p = Tcl_UtfAtIndex(string1, index);
            end = string1+length1;
            for (cur = index; p < end; cur++) {
                p += Tcl_UtfToUniChar(p, &ch);
                if (!Tcl_UniCharIsWordChar(ch)) {
                  break;
                }
            }
            if (cur == index) {
                cur++;
            }
          } else {
            cur = numChars;
          }
          Tcl_SetIntObj(resultPtr, cur);
          break;
      }
      case STR_WORDSTART: {
          int cur;
          Tcl_UniChar ch;
          char *p;
          int numChars;
          
          if (objc != 4) {
              Tcl_WrongNumArgs(interp, 2, objv, "string index");
            return TCL_ERROR;
          }

          string1 = Tcl_GetStringFromObj(objv[2], &length1);
          numChars = Tcl_NumUtfChars(string1, length1);
          if (TclGetIntForIndex(interp, objv[3], numChars-1,
                          &index) != TCL_OK) {
            return TCL_ERROR;
          }
          if (index >= numChars) {
            index = numChars - 1;
          }
          cur = 0;
          if (index > 0) {
            p = Tcl_UtfAtIndex(string1, index);
              for (cur = index; cur >= 0; cur--) {
                Tcl_UtfToUniChar(p, &ch);
                if (!Tcl_UniCharIsWordChar(ch)) {
                  break;
                }
                p = Tcl_UtfPrev(p, string1);
            }
            if (cur != index) {
                cur += 1;
            }
          }
          Tcl_SetIntObj(resultPtr, cur);
          break;
      }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObjCmd --
 *
 *    This procedure is invoked to process the "subst" Tcl command.
 *    See the user documentation for details on what it does.  This
 *    command is an almost direct copy of an implementation by
 *    Andrew Payne.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    static char *substOptions[] = {
      "-nobackslashes", "-nocommands", "-novariables", (char *) NULL
    };
    enum substOptions {
      SUBST_NOBACKSLASHES,      SUBST_NOCOMMANDS,       SUBST_NOVARS
    };
    Interp *iPtr = (Interp *) interp;
    Tcl_DString result;
    char *p, *old, *value;
    int optionIndex, code, count, doVars, doCmds, doBackslashes, i;

    /*
     * Parse command-line options.
     */

    doVars = doCmds = doBackslashes = 1;
    for (i = 1; i < (objc-1); i++) {
      p = Tcl_GetString(objv[i]);
      if (*p != '-') {
          break;
      }
      if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
            "switch", 0, &optionIndex) != TCL_OK) {

          return TCL_ERROR;
      }
      switch (optionIndex) {
          case SUBST_NOBACKSLASHES: {
            doBackslashes = 0;
            break;
          }
          case SUBST_NOCOMMANDS: {
            doCmds = 0;
            break;
          }
          case SUBST_NOVARS: {
            doVars = 0;
            break;
          }
          default: {
            panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
          }
      }
    }
    if (i != (objc-1)) {
      Tcl_WrongNumArgs(interp, 1, objv,
            "?-nobackslashes? ?-nocommands? ?-novariables? string");
      return TCL_ERROR;
    }

    /*
     * Scan through the string one character at a time, performing
     * command, variable, and backslash substitutions.
     */

    Tcl_DStringInit(&result);
    old = p = Tcl_GetString(objv[i]);
    while (*p != 0) {
      switch (*p) {
          case '\\':
            if (doBackslashes) {
                char buf[TCL_UTF_MAX];

                if (p != old) {
                  Tcl_DStringAppend(&result, old, p-old);
                }
                Tcl_DStringAppend(&result, buf,
                      Tcl_UtfBackslash(p, &count, buf));
                p += count;
                old = p;
            } else {
                p++;
            }
            break;

          case '$':
            if (doVars) {
                if (p != old) {
                  Tcl_DStringAppend(&result, old, p-old);
                }
                value = Tcl_ParseVar(interp, p, &p);
                if (value == NULL) {
                  Tcl_DStringFree(&result);
                  return TCL_ERROR;
                }
                Tcl_DStringAppend(&result, value, -1);
                old = p;
            } else {
                p++;
            }
            break;

          case '[':
            if (doCmds) {
                if (p != old) {
                  Tcl_DStringAppend(&result, old, p-old);
                }
                iPtr->evalFlags = TCL_BRACKET_TERM;
                code = Tcl_Eval(interp, p+1);
                if (code == TCL_ERROR) {
                  Tcl_DStringFree(&result);
                  return code;
                }
                old = p = (p+1 + iPtr->termOffset+1);
                Tcl_DStringAppend(&result, iPtr->result, -1);
                Tcl_ResetResult(interp);
            } else {
                p++;
            }
            break;

          default:
            p++;
            break;
      }
    }
    if (p != old) {
      Tcl_DStringAppend(&result, old, p-old);
    }
    Tcl_DStringResult(interp, &result);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SwitchObjCmd --
 *
 *    This object-based procedure is invoked to process the "switch" Tcl
 *    command. See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    int i, j, index, mode, matched, result, splitObjs, seenComment;
    char *string, *pattern;
    Tcl_Obj *stringObj;
    static char *options[] = {
      "-exact",   "-glob",    "-regexp",  "--", 
      NULL
    };
    enum options {
      OPT_EXACT,  OPT_GLOB,   OPT_REGEXP, OPT_LAST
    };

    mode = OPT_EXACT;
    for (i = 1; i < objc; i++) {
      string = Tcl_GetString(objv[i]);
      if (string[0] != '-') {
          break;
      }
      if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 
            &index) != TCL_OK) {
          return TCL_ERROR;
      }
      if (index == OPT_LAST) {
          i++;
          break;
      }
      mode = index;
    }

    if (objc - i < 2) {
      Tcl_WrongNumArgs(interp, 1, objv,
            "?switches? string pattern body ... ?default body?");
      return TCL_ERROR;
    }

    stringObj = objv[i];
    objc -= i + 1;
    objv += i + 1;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    splitObjs = 0;
    if (objc == 1) {
      Tcl_Obj **listv;

      if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
          return TCL_ERROR;
      }
      objv = listv;
      splitObjs = 1;
    }

    seenComment = 0;
    for (i = 0; i < objc; i += 2) {
      if (i == objc - 1) {
          Tcl_ResetResult(interp);
          Tcl_AppendToObj(Tcl_GetObjResult(interp),
                  "extra switch pattern with no body", -1);

          /*
           * Check if this can be due to a badly placed comment
           * in the switch block
           */

          if (splitObjs && seenComment) {
            Tcl_AppendToObj(Tcl_GetObjResult(interp),
                  ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
          }

          return TCL_ERROR;
      }

      /*
       * See if the pattern matches the string.
       */

      pattern = Tcl_GetString(objv[i]);

      /*
       * The following is an heuristic to detect the infamous
       * "comment in switch" error: just check if a pattern
       * begins with '#'.
       */

      if (splitObjs && *pattern == '#') {
          seenComment = 1;
      }

      matched = 0;
      if ((i == objc - 2) 
            && (*pattern == 'd') 
            && (strcmp(pattern, "default") == 0)) {
          matched = 1;
      } else {
          switch (mode) {
            case OPT_EXACT:
                matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
                break;
            case OPT_GLOB:
                matched = Tcl_StringMatch(Tcl_GetString(stringObj),
                      pattern);
                break;
            case OPT_REGEXP:
                matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
                if (matched < 0) {
                  return TCL_ERROR;
                }
                break;
          }
      }
      if (matched == 0) {
          continue;
      }

      /*
       * We've got a match. Find a body to execute, skipping bodies
       * that are "-".
       */

      for (j = i + 1; ; j += 2) {
          if (j >= objc) {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                  "no body specified for pattern \"", pattern,
                  "\"", (char *) NULL);
            return TCL_ERROR;
          }
          if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
            break;
          }
      }
      result = Tcl_EvalObjEx(interp, objv[j], 0);
      if (result == TCL_ERROR) {
          char msg[100 + TCL_INTEGER_SPACE];

          sprintf(msg, "\n    (\"%.50s\" arm line %d)", pattern,
                interp->errorLine);
          Tcl_AddObjErrorInfo(interp, msg, -1);
      }
      return result;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TimeObjCmd --
 *
 *    This object-based procedure is invoked to process the "time" Tcl
 *    command.  See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl object result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_TimeObjCmd(dummy, interp, objc, objv)
    ClientData dummy;         /* Not used. */
    Tcl_Interp *interp;       /* Current interpreter. */
    int objc;                 /* Number of arguments. */
    Tcl_Obj *CONST objv[];    /* Argument objects. */
{
    register Tcl_Obj *objPtr;
    register int i, result;
    int count;
    double totalMicroSec;
    Tcl_Time start, stop;
    char buf[100];

    if (objc == 2) {
      count = 1;
    } else if (objc == 3) {
      result = Tcl_GetIntFromObj(interp, objv[2], &count);
      if (result != TCL_OK) {
          return result;
      }
    } else {
      Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
      return TCL_ERROR;
    }
    
    objPtr = objv[1];
    i = count;
    TclpGetTime(&start);
    while (i-- > 0) {
      result = Tcl_EvalObjEx(interp, objPtr, 0);
      if (result != TCL_OK) {
          return result;
      }
    }
    TclpGetTime(&stop);
    
    totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
                  + ( stop.usec - start.usec ) );
    sprintf(buf, "%.0f microseconds per iteration",
      ((count <= 0) ? 0 : totalMicroSec/count));
    Tcl_ResetResult(interp);
    Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceObjCmd --
 *
 *    This procedure is invoked to process the "trace" Tcl command.
 *    See the user documentation for details on what it does.
 *
 * Results:
 *    A standard Tcl result.
 *
 * Side effects:
 *    See the user documentation.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
    ClientData dummy;               /* Not used. */
    Tcl_Interp *interp;             /* Current interpreter. */
    int objc;                       /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    int optionIndex, commandLength;
    char *name, *rwuOps, *command, *p;
    size_t length;
    static char *traceOptions[] = {
      "variable", "vdelete", "vinfo", (char *) NULL
    };
    enum traceOptions {
      TRACE_VARIABLE,       TRACE_VDELETE,      TRACE_VINFO
    };

    if (objc < 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]");
      return TCL_ERROR;
    }

    if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
            "option", 0, &optionIndex) != TCL_OK) {
      return TCL_ERROR;
    }
    switch ((enum traceOptions) optionIndex) {
          case TRACE_VARIABLE: {
            int flags;
            TraceVarInfo *tvarPtr;
            if (objc != 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
                return TCL_ERROR;
            }

            flags = 0;
            rwuOps = Tcl_GetString(objv[3]);
            for (p = rwuOps; *p != 0; p++) {
                if (*p == 'r') {
                  flags |= TCL_TRACE_READS;
                } else if (*p == 'w') {
                  flags |= TCL_TRACE_WRITES;
                } else if (*p == 'u') {
                  flags |= TCL_TRACE_UNSETS;
                } else {
                  goto badOps;
                }
            }
            if (flags == 0) {
                goto badOps;
            }

            command = Tcl_GetStringFromObj(objv[4], &commandLength);
            length = (size_t) commandLength;
            tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
                  (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
                        + length + 1));
            tvarPtr->flags = flags;
            tvarPtr->errMsg = NULL;
            tvarPtr->length = length;
            flags |= TCL_TRACE_UNSETS;
            strcpy(tvarPtr->command, command);
            name = Tcl_GetString(objv[2]);
            if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
                  (ClientData) tvarPtr) != TCL_OK) {
                ckfree((char *) tvarPtr);
                return TCL_ERROR;
            }
            break;
          }
          case TRACE_VDELETE: {
            int flags;
            TraceVarInfo *tvarPtr;
            ClientData clientData;

            if (objc != 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
                return TCL_ERROR;
            }

            flags = 0;
            rwuOps = Tcl_GetString(objv[3]);
            for (p = rwuOps; *p != 0; p++) {
                if (*p == 'r') {
                  flags |= TCL_TRACE_READS;
                } else if (*p == 'w') {
                  flags |= TCL_TRACE_WRITES;
                } else if (*p == 'u') {
                  flags |= TCL_TRACE_UNSETS;
                } else {
                  goto badOps;
                }
            }
            if (flags == 0) {
                goto badOps;
            }

            /*
             * Search through all of our traces on this variable to
             * see if there's one with the given command.  If so, then
             * delete the first one that matches.
             */
            
            command = Tcl_GetStringFromObj(objv[4], &commandLength);
            length = (size_t) commandLength;
            clientData = 0;
            name = Tcl_GetString(objv[2]);
            while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                  TraceVarProc, clientData)) != 0) {
                tvarPtr = (TraceVarInfo *) clientData;
                if ((tvarPtr->length == length)
                      && (tvarPtr->flags == flags)
                      && (strncmp(command, tvarPtr->command,
                            (size_t) length) == 0)) {
                  Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
                        TraceVarProc, clientData);
                  if (tvarPtr->errMsg != NULL) {
                      ckfree(tvarPtr->errMsg);
                  }
                  ckfree((char *) tvarPtr);
                  break;
                }
            }
            break;
          }
          case TRACE_VINFO: {
            ClientData clientData;
            char ops[4];
            Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;

            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "name");
                return TCL_ERROR;
            }
            resultListPtr = Tcl_GetObjResult(interp);
            clientData = 0;
            name = Tcl_GetString(objv[2]);
            while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                  TraceVarProc, clientData)) != 0) {

                TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

                pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
                p = ops;
                if (tvarPtr->flags & TCL_TRACE_READS) {
                  *p = 'r';
                  p++;
                }
                if (tvarPtr->flags & TCL_TRACE_WRITES) {
                  *p = 'w';
                  p++;
                }
                if (tvarPtr->flags & TCL_TRACE_UNSETS) {
                  *p = 'u';
                  p++;
                }
                *p = '\0';

                /*
                 * Build a pair (2-item list) with the ops string as
                 * the first obj element and the tvarPtr->command string
                 * as the second obj element.  Append the pair (as an
                 * element) to the end of the result object list.
                 */

                elemObjPtr = Tcl_NewStringObj(ops, -1);
                Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
                elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
                Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
                Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
            }
            Tcl_SetObjResult(interp, resultListPtr);
            break;
          }
      default: {
            panic("Tcl_TraceObjCmd: bad option index to TraceOptions");
          }
    }
    return TCL_OK;

    badOps:
    Tcl_AppendResult(interp, "bad operations \"", rwuOps,
          "\": should be one or more of rwu", (char *) NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *    This procedure is called to handle variable accesses that have
 *    been traced using the "trace" command.
 *
 * Results:
 *    Normally returns NULL.  If the trace command returns an error,
 *    then this procedure returns an error string.
 *
 * Side effects:
 *    Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

      /* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;    /* Information about the variable trace. */
    Tcl_Interp *interp;       /* Interpreter containing variable. */
    char *name1;        /* Name of variable or array. */
    char *name2;        /* Name of element within array;  NULL means
                         * scalar variable is being referenced. */
    int flags;                /* OR-ed bits giving operation and other
                         * information. */
{
    Tcl_SavedResult state;
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;

    result = NULL;
    if (tvarPtr->errMsg != NULL) {
      ckfree(tvarPtr->errMsg);
      tvarPtr->errMsg = NULL;
    }
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {

      /*
       * Generate a command to execute by appending list elements
       * for the two variable names and the operation.  The five
       * extra characters are for three space, the opcode character,
       * and the terminating null.
       */

      Tcl_DStringInit(&cmd);
      Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
      Tcl_DStringAppendElement(&cmd, name1);
      Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
      if (flags & TCL_TRACE_READS) {
          Tcl_DStringAppend(&cmd, " r", 2);
      } else if (flags & TCL_TRACE_WRITES) {
          Tcl_DStringAppend(&cmd, " w", 2);
      } else if (flags & TCL_TRACE_UNSETS) {
          Tcl_DStringAppend(&cmd, " u", 2);
      }

      /*
       * Execute the command.  Save the interp's result used for
       * the command. We discard any object result the command returns.
       *
       * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
       * other areas that this will be destroyed by us, otherwise a
       * double-free might occur depending on what the eval does.
       * [Bug #536937]
       */

      Tcl_SaveResult(interp, &state);
      if (flags & TCL_TRACE_DESTROYED) {
          tvarPtr->flags |= TCL_TRACE_DESTROYED;
      }

      code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
      if (code != TCL_OK) {        /* copy error msg to result */
          char *string;
          int length;
          
          string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
          tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
          memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
          result = tvarPtr->errMsg;
      }

      Tcl_RestoreResult(interp, &state);

      Tcl_DStringFree(&cmd);
    }
    if (flags & TCL_TRACE_DESTROYED) {
      result = NULL;
      if (tvarPtr->errMsg != NULL) {
          ckfree(tvarPtr->errMsg);
      }
      ckfree((char *) tvarPtr);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --
 *
 *      This procedure is invoked to process the "while" Tcl command.
 *      See the user documentation for details on what it does.
 *
 *    With the bytecode compiler, this procedure is only called when
 *    a command name is computed at runtime, and is "while" or the name
 *    to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];          /* Argument objects. */
{
    int result, value;

    if (objc != 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "test command");
        return TCL_ERROR;
    }

    while (1) {
        result = Tcl_ExprBooleanObj(interp, objv[1], &value);
        if (result != TCL_OK) {
            return result;
        }
        if (!value) {
            break;
        }
        result = Tcl_EvalObjEx(interp, objv[2], 0);
        if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
            if (result == TCL_ERROR) {
                char msg[32 + TCL_INTEGER_SPACE];

                sprintf(msg, "\n    (\"while\" body line %d)",
                        interp->errorLine);
                Tcl_AddErrorInfo(interp, msg);
            }
            break;
        }
    }
    if (result == TCL_BREAK) {
        result = TCL_OK;
    }
    if (result == TCL_OK) {
        Tcl_ResetResult(interp);
    }
    return result;
}


Generated by  Doxygen 1.6.0   Back to index