/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdmz.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdmz.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclcmdmz.c,v 1.1.1.1 2001/06/13 04:35:16 dtashley Exp $ */  
   
 /*  
  * 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-1999 by 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.1.1.1 2001/06/13 04:35:16 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclPort.h"  
 #include "tclCompile.h"  
 #include "tclRegexp.h"  
   
 /*  
  * Flag values used by Tcl_ScanObjCmd.  
  */  
   
 #define SCAN_NOSKIP     0x1               /* Don't skip blanks. */  
 #define SCAN_SUPPRESS   0x2               /* Suppress assignment. */  
 #define SCAN_UNSIGNED   0x4               /* Read an unsigned value. */  
 #define SCAN_WIDTH      0x8               /* A width value was supplied. */  
   
 #define SCAN_SIGNOK     0x10              /* A +/- character is allowed. */  
 #define SCAN_NODIGITS   0x20              /* No digits have been scanned. */  
 #define SCAN_NOZERO     0x40              /* No zero digits have been scanned. */  
 #define SCAN_XOK        0x80              /* An 'x' is allowed. */  
 #define SCAN_PTOK       0x100             /* Decimal point is allowed. */  
 #define SCAN_EXPOK      0x200             /* An exponent is allowed. */  
   
 /*  
  * 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;  
     }  
   
     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);  
     if (regExpr == NULL) {  
         return TCL_ERROR;  
     }  
     objPtr = objv[1];  
   
     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;  
     }  
   
     /*  
      * Get the length of the string that we are matching against so  
      * we can do the termination test for -all matches.  
      */  
     stringLength = Tcl_GetCharLength(objPtr);  
       
     /*  
      * 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];  
   
                 if (i <= info.nsubs) {  
                     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++;  
         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;  
   
     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);  
     if (regExpr == NULL) {  
         return TCL_ERROR;  
     }  
   
     result = TCL_OK;  
     resultPtr = Tcl_NewObj();  
     Tcl_IncrRefCount(resultPtr);  
   
     objPtr = objv[1];  
     wlen = Tcl_GetCharLength(objPtr);  
     wstring = Tcl_GetUnicode(objPtr);  
     subspec = Tcl_GetString(objv[2]);  
     varPtr = objv[3];  
   
     /*  
      * 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) {  
         /*  
          * Handle the special case of splitting on every character.  
          */  
   
         for ( ; string < end; string += len) {  
             len = Tcl_UtfToUniChar(string, &ch);  
             objPtr = Tcl_NewStringObj(string, len);  
             Tcl_ListObjAppendElement(NULL, listPtr, objPtr);  
         }  
     } 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: {  
             char buf[TCL_UTF_MAX];  
             Tcl_UniChar unichar;  
   
             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;  
                 }  
                 Tcl_SetByteArrayObj(resultPtr,  
                         (unsigned char *)(&string1[index]), 1);  
             } else {  
                 string1 = Tcl_GetStringFromObj(objv[2], &length1);  
                   
                 /*  
                  * convert to Unicode internal rep to calulate what  
                  * 'end' really means.  
                  */  
   
                 length2 = Tcl_GetCharLength(objv[2]);  
       
                 if (TclGetIntForIndex(interp, objv[3], length2 - 1,  
                         &index) != TCL_OK) {  
                     return TCL_ERROR;  
                 }  
                 if ((index >= 0) && (index < length2)) {  
                     unichar = Tcl_GetUniChar(objv[2], index);  
                     length2 = Tcl_UniCharToUtf((int)unichar, buf);  
                     Tcl_SetStringObj(resultPtr, buf, length2);  
                 }  
             }  
             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);  
                 Tcl_SetIntObj(resultPtr, 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);  
                     Tcl_SetIntObj(resultPtr, length1);  
                 } else {  
                     Tcl_SetIntObj(resultPtr,  
                             Tcl_GetCharLength(objv[2]));  
                 }  
             }  
             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]);  
             } 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;  
             }  
   
             string1 = Tcl_GetStringFromObj(objv[2], &length1);  
             if (length1 > 0) {  
                 for (index = 0; index < count; index++) {  
                     Tcl_AppendToObj(resultPtr, string1, length1);  
                 }  
             }  
             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 =  
         (stop.sec - start.sec)*1000000 + (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.  
          */  
   
         if (name2 == NULL) {  
             name2 = "";  
         }  
         Tcl_DStringInit(&cmd);  
         Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);  
         Tcl_DStringAppendElement(&cmd, name1);  
         Tcl_DStringAppendElement(&cmd, 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.  
          */  
   
         Tcl_SaveResult(interp, &state);  
   
         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;  
 }  
   
   
 /* $History: tclcmdmz.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:28a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLCMDMZ.C */  
1    /* $Header$ */
2    /*
3     * tclCmdMZ.c --
4     *
5     *      This file contains the top-level command routines for most of
6     *      the Tcl built-in commands whose names begin with the letters
7     *      M to Z.  It contains only commands in the generic core (i.e.
8     *      those that don't depend much upon UNIX facilities).
9     *
10     * Copyright (c) 1987-1993 The Regents of the University of California.
11     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12     * Copyright (c) 1998-1999 by Scriptics Corporation.
13     *
14     * See the file "license.terms" for information on usage and redistribution
15     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16     *
17     * RCS: @(#) $Id: tclcmdmz.c,v 1.1.1.1 2001/06/13 04:35:16 dtashley Exp $
18     */
19    
20    #include "tclInt.h"
21    #include "tclPort.h"
22    #include "tclCompile.h"
23    #include "tclRegexp.h"
24    
25    /*
26     * Flag values used by Tcl_ScanObjCmd.
27     */
28    
29    #define SCAN_NOSKIP     0x1               /* Don't skip blanks. */
30    #define SCAN_SUPPRESS   0x2               /* Suppress assignment. */
31    #define SCAN_UNSIGNED   0x4               /* Read an unsigned value. */
32    #define SCAN_WIDTH      0x8               /* A width value was supplied. */
33    
34    #define SCAN_SIGNOK     0x10              /* A +/- character is allowed. */
35    #define SCAN_NODIGITS   0x20              /* No digits have been scanned. */
36    #define SCAN_NOZERO     0x40              /* No zero digits have been scanned. */
37    #define SCAN_XOK        0x80              /* An 'x' is allowed. */
38    #define SCAN_PTOK       0x100             /* Decimal point is allowed. */
39    #define SCAN_EXPOK      0x200             /* An exponent is allowed. */
40    
41    /*
42     * Structure used to hold information about variable traces:
43     */
44    
45    typedef struct {
46        int flags;                  /* Operations for which Tcl command is
47                                     * to be invoked. */
48        char *errMsg;               /* Error message returned from Tcl command,
49                                     * or NULL.  Malloc'ed. */
50        size_t length;              /* Number of non-NULL chars. in command. */
51        char command[4];            /* Space for Tcl command to invoke.  Actual
52                                     * size will be as large as necessary to
53                                     * hold command.  This field must be the
54                                     * last in the structure, so that it can
55                                     * be larger than 4 bytes. */
56    } TraceVarInfo;
57    
58    /*
59     * Forward declarations for procedures defined in this file:
60     */
61    
62    static char *           TraceVarProc _ANSI_ARGS_((ClientData clientData,
63                                Tcl_Interp *interp, char *name1, char *name2,
64                                int flags));
65    
66    /*
67     *----------------------------------------------------------------------
68     *
69     * Tcl_PwdObjCmd --
70     *
71     *      This procedure is invoked to process the "pwd" Tcl command.
72     *      See the user documentation for details on what it does.
73     *
74     * Results:
75     *      A standard Tcl result.
76     *
77     * Side effects:
78     *      See the user documentation.
79     *
80     *----------------------------------------------------------------------
81     */
82    
83            /* ARGSUSED */
84    int
85    Tcl_PwdObjCmd(dummy, interp, objc, objv)
86        ClientData dummy;                   /* Not used. */
87        Tcl_Interp *interp;                 /* Current interpreter. */
88        int objc;                           /* Number of arguments. */
89        Tcl_Obj *CONST objv[];              /* Argument objects. */
90    {
91        Tcl_DString ds;
92    
93        if (objc != 1) {
94            Tcl_WrongNumArgs(interp, 1, objv, NULL);
95            return TCL_ERROR;
96        }
97    
98        if (Tcl_GetCwd(interp, &ds) == NULL) {
99            return TCL_ERROR;
100        }
101        Tcl_DStringResult(interp, &ds);
102        return TCL_OK;
103    }
104    
105    /*
106     *----------------------------------------------------------------------
107     *
108     * Tcl_RegexpObjCmd --
109     *
110     *      This procedure is invoked to process the "regexp" Tcl command.
111     *      See the user documentation for details on what it does.
112     *
113     * Results:
114     *      A standard Tcl result.
115     *
116     * Side effects:
117     *      See the user documentation.
118     *
119     *----------------------------------------------------------------------
120     */
121    
122            /* ARGSUSED */
123    int
124    Tcl_RegexpObjCmd(dummy, interp, objc, objv)
125        ClientData dummy;                   /* Not used. */
126        Tcl_Interp *interp;                 /* Current interpreter. */
127        int objc;                           /* Number of arguments. */
128        Tcl_Obj *CONST objv[];              /* Argument objects. */
129    {
130        int i, indices, match, about, offset, all, doinline, numMatchesSaved;
131        int cflags, eflags, stringLength;
132        Tcl_RegExp regExpr;
133        Tcl_Obj *objPtr, *resultPtr;
134        Tcl_RegExpInfo info;
135        static char *options[] = {
136            "-all",         "-about",       "-indices",     "-inline",
137            "-expanded",    "-line",        "-linestop",    "-lineanchor",
138            "-nocase",      "-start",       "--",           (char *) NULL
139        };
140        enum options {
141            REGEXP_ALL,     REGEXP_ABOUT,   REGEXP_INDICES, REGEXP_INLINE,
142            REGEXP_EXPANDED,REGEXP_LINE,    REGEXP_LINESTOP,REGEXP_LINEANCHOR,
143            REGEXP_NOCASE,  REGEXP_START,   REGEXP_LAST
144        };
145    
146        indices     = 0;
147        about       = 0;
148        cflags      = TCL_REG_ADVANCED;
149        eflags      = 0;
150        offset      = 0;
151        all         = 0;
152        doinline    = 0;
153        
154        for (i = 1; i < objc; i++) {
155            char *name;
156            int index;
157    
158            name = Tcl_GetString(objv[i]);
159            if (name[0] != '-') {
160                break;
161            }
162            if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
163                    &index) != TCL_OK) {
164                return TCL_ERROR;
165            }
166            switch ((enum options) index) {
167                case REGEXP_ALL: {
168                    all = 1;
169                    break;
170                }
171                case REGEXP_INDICES: {
172                    indices = 1;
173                    break;
174                }
175                case REGEXP_INLINE: {
176                    doinline = 1;
177                    break;
178                }
179                case REGEXP_NOCASE: {
180                    cflags |= TCL_REG_NOCASE;
181                    break;
182                }
183                case REGEXP_ABOUT: {
184                    about = 1;
185                    break;
186                }
187                case REGEXP_EXPANDED: {
188                    cflags |= TCL_REG_EXPANDED;
189                    break;
190                }
191                case REGEXP_LINE: {
192                    cflags |= TCL_REG_NEWLINE;
193                    break;
194                }
195                case REGEXP_LINESTOP: {
196                    cflags |= TCL_REG_NLSTOP;
197                    break;
198                }
199                case REGEXP_LINEANCHOR: {
200                    cflags |= TCL_REG_NLANCH;
201                    break;
202                }
203                case REGEXP_START: {
204                    if (++i >= objc) {
205                        goto endOfForLoop;
206                    }
207                    if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
208                        return TCL_ERROR;
209                    }
210                    if (offset < 0) {
211                        offset = 0;
212                    }
213                    break;
214                }
215                case REGEXP_LAST: {
216                    i++;
217                    goto endOfForLoop;
218                }
219            }
220        }
221    
222        endOfForLoop:
223        if ((objc - i) < (2 - about)) {
224            Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
225            return TCL_ERROR;
226        }
227        objc -= i;
228        objv += i;
229    
230        if (doinline && ((objc - 2) != 0)) {
231            /*
232             * User requested -inline, but specified match variables - a no-no.
233             */
234            Tcl_AppendResult(interp, "regexp match variables not allowed",
235                    " when using -inline", (char *) NULL);
236            return TCL_ERROR;
237        }
238    
239        regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
240        if (regExpr == NULL) {
241            return TCL_ERROR;
242        }
243        objPtr = objv[1];
244    
245        if (about) {
246            if (TclRegAbout(interp, regExpr) < 0) {
247                return TCL_ERROR;
248            }
249            return TCL_OK;
250        }
251    
252        if (offset > 0) {
253            /*
254             * Add flag if using offset (string is part of a larger string),
255             * so that "^" won't match.
256             */
257            eflags |= TCL_REG_NOTBOL;
258        }
259    
260        objc -= 2;
261        objv += 2;
262        resultPtr = Tcl_GetObjResult(interp);
263    
264        if (doinline) {
265            /*
266             * Save all the subexpressions, as we will return them as a list
267             */
268            numMatchesSaved = -1;
269        } else {
270            /*
271             * Save only enough subexpressions for matches we want to keep,
272             * expect in the case of -all, where we need to keep at least
273             * one to know where to move the offset.
274             */
275            numMatchesSaved = (objc == 0) ? all : objc;
276        }
277    
278        /*
279         * Get the length of the string that we are matching against so
280         * we can do the termination test for -all matches.
281         */
282        stringLength = Tcl_GetCharLength(objPtr);
283        
284        /*
285         * The following loop is to handle multiple matches within the
286         * same source string;  each iteration handles one match.  If "-all"
287         * hasn't been specified then the loop body only gets executed once.
288         * We terminate the loop when the starting offset is past the end of the
289         * string.
290         */
291    
292        while (1) {
293            match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
294                    offset /* offset */, numMatchesSaved, eflags);
295    
296            if (match < 0) {
297                return TCL_ERROR;
298            }
299    
300            if (match == 0) {
301                /*
302                 * We want to set the value of the intepreter result only when
303                 * this is the first time through the loop.
304                 */
305                if (all <= 1) {
306                    /*
307                     * If inlining, set the interpreter's object result to an
308                     * empty list, otherwise set it to an integer object w/
309                     * value 0.
310                     */
311                    if (doinline) {
312                        Tcl_SetListObj(resultPtr, 0, NULL);
313                    } else {
314                        Tcl_SetIntObj(resultPtr, 0);
315                    }
316                    return TCL_OK;
317                }
318                break;
319            }
320    
321            /*
322             * If additional variable names have been specified, return
323             * index information in those variables.
324             */
325    
326            Tcl_RegExpGetInfo(regExpr, &info);
327            if (doinline) {
328                /*
329                 * It's the number of substitutions, plus one for the matchVar
330                 * at index 0
331                 */
332                objc = info.nsubs + 1;
333            }
334            for (i = 0; i < objc; i++) {
335                Tcl_Obj *newPtr;
336    
337                if (indices) {
338                    int start, end;
339                    Tcl_Obj *objs[2];
340    
341                    if (i <= info.nsubs) {
342                        start = offset + info.matches[i].start;
343                        end   = offset + info.matches[i].end;
344    
345                        /*
346                         * Adjust index so it refers to the last character in the
347                         * match instead of the first character after the match.
348                         */
349    
350                        if (end >= offset) {
351                            end--;
352                        }
353                    } else {
354                        start = -1;
355                        end   = -1;
356                    }
357    
358                    objs[0] = Tcl_NewLongObj(start);
359                    objs[1] = Tcl_NewLongObj(end);
360    
361                    newPtr = Tcl_NewListObj(2, objs);
362                } else {
363                    if (i <= info.nsubs) {
364                        newPtr = Tcl_GetRange(objPtr,
365                                offset + info.matches[i].start,
366                                offset + info.matches[i].end - 1);
367                    } else {
368                        newPtr = Tcl_NewObj();
369                    }
370                }
371                if (doinline) {
372                    if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
373                            != TCL_OK) {
374                        Tcl_DecrRefCount(newPtr);
375                        return TCL_ERROR;
376                    }
377                } else {
378                    Tcl_Obj *valuePtr;
379                    valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
380                    if (valuePtr == NULL) {
381                        Tcl_DecrRefCount(newPtr);
382                        Tcl_AppendResult(interp, "couldn't set variable \"",
383                                Tcl_GetString(objv[i]), "\"", (char *) NULL);
384                        return TCL_ERROR;
385                    }
386                }
387            }
388    
389            if (all == 0) {
390                break;
391            }
392            /*
393             * Adjust the offset to the character just after the last one
394             * in the matchVar and increment all to count how many times
395             * we are making a match.  We always increment the offset by at least
396             * one to prevent endless looping (as in the case:
397             * regexp -all {a*} a).  Otherwise, when we match the NULL string at
398             * the end of the input string, we will loop indefinately (because the
399             * length of the match is 0, so offset never changes).
400             */
401            if (info.matches[0].end == 0) {
402                offset++;
403            }
404            offset += info.matches[0].end;
405            all++;
406            if (offset >= stringLength) {
407                break;
408            }
409        }
410    
411        /*
412         * Set the interpreter's object result to an integer object
413         * with value 1 if -all wasn't specified, otherwise it's all-1
414         * (the number of times through the while - 1).
415         */
416    
417        if (!doinline) {
418            Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
419        }
420        return TCL_OK;
421    }
422    
423    /*
424     *----------------------------------------------------------------------
425     *
426     * Tcl_RegsubObjCmd --
427     *
428     *      This procedure is invoked to process the "regsub" Tcl command.
429     *      See the user documentation for details on what it does.
430     *
431     * Results:
432     *      A standard Tcl result.
433     *
434     * Side effects:
435     *      See the user documentation.
436     *
437     *----------------------------------------------------------------------
438     */
439    
440            /* ARGSUSED */
441    int
442    Tcl_RegsubObjCmd(dummy, interp, objc, objv)
443        ClientData dummy;                   /* Not used. */
444        Tcl_Interp *interp;                 /* Current interpreter. */
445        int objc;                           /* Number of arguments. */
446        Tcl_Obj *CONST objv[];              /* Argument objects. */
447    {
448        int i, result, cflags, all, wlen, numMatches, offset;
449        Tcl_RegExp regExpr;
450        Tcl_Obj *resultPtr, *varPtr, *objPtr;
451        Tcl_UniChar *wstring;
452        char *subspec;
453    
454        static char *options[] = {
455            "-all",         "-nocase",      "-expanded",
456            "-line",        "-linestop",    "-lineanchor",  "-start",
457            "--",           NULL
458        };
459        enum options {
460            REGSUB_ALL,     REGSUB_NOCASE,  REGSUB_EXPANDED,
461            REGSUB_LINE,    REGSUB_LINESTOP, REGSUB_LINEANCHOR,     REGSUB_START,
462            REGSUB_LAST
463        };
464    
465        cflags = TCL_REG_ADVANCED;
466        all = 0;
467        offset = 0;
468    
469        for (i = 1; i < objc; i++) {
470            char *name;
471            int index;
472            
473            name = Tcl_GetString(objv[i]);
474            if (name[0] != '-') {
475                break;
476            }
477            if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
478                    &index) != TCL_OK) {
479                return TCL_ERROR;
480            }
481            switch ((enum options) index) {
482                case REGSUB_ALL: {
483                    all = 1;
484                    break;
485                }
486                case REGSUB_NOCASE: {
487                    cflags |= TCL_REG_NOCASE;
488                    break;
489                }
490                case REGSUB_EXPANDED: {
491                    cflags |= TCL_REG_EXPANDED;
492                    break;
493                }
494                case REGSUB_LINE: {
495                    cflags |= TCL_REG_NEWLINE;
496                    break;
497                }
498                case REGSUB_LINESTOP: {
499                    cflags |= TCL_REG_NLSTOP;
500                    break;
501                }
502                case REGSUB_LINEANCHOR: {
503                    cflags |= TCL_REG_NLANCH;
504                    break;
505                }
506                case REGSUB_START: {
507                    if (++i >= objc) {
508                        goto endOfForLoop;
509                    }
510                    if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
511                        return TCL_ERROR;
512                    }
513                    if (offset < 0) {
514                        offset = 0;
515                    }
516                    break;
517                }
518                case REGSUB_LAST: {
519                    i++;
520                    goto endOfForLoop;
521                }
522            }
523        }
524        endOfForLoop:
525        if (objc - i != 4) {
526            Tcl_WrongNumArgs(interp, 1, objv,
527                    "?switches? exp string subSpec varName");
528            return TCL_ERROR;
529        }
530    
531        objv += i;
532    
533        regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
534        if (regExpr == NULL) {
535            return TCL_ERROR;
536        }
537    
538        result = TCL_OK;
539        resultPtr = Tcl_NewObj();
540        Tcl_IncrRefCount(resultPtr);
541    
542        objPtr = objv[1];
543        wlen = Tcl_GetCharLength(objPtr);
544        wstring = Tcl_GetUnicode(objPtr);
545        subspec = Tcl_GetString(objv[2]);
546        varPtr = objv[3];
547    
548        /*
549         * The following loop is to handle multiple matches within the
550         * same source string;  each iteration handles one match and its
551         * corresponding substitution.  If "-all" hasn't been specified
552         * then the loop body only gets executed once.
553         */
554    
555        numMatches = 0;
556        for ( ; offset < wlen; ) {
557            int start, end, subStart, subEnd, match;
558            char *src, *firstChar;
559            char c;
560            Tcl_RegExpInfo info;
561    
562            /*
563             * The flags argument is set if string is part of a larger string,
564             * so that "^" won't match.
565             */
566    
567            match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
568                    10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0));
569    
570            if (match < 0) {
571                result = TCL_ERROR;
572                goto done;
573            }
574            if (match == 0) {
575                break;
576            }
577            if ((numMatches == 0) && (offset > 0)) {
578                /* Copy the initial portion of the string in if an offset
579                 * was specified.
580                 */
581                Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
582            }
583            numMatches++;
584    
585            /*
586             * Copy the portion of the source string before the match to the
587             * result variable.
588             */
589    
590            Tcl_RegExpGetInfo(regExpr, &info);
591            start = info.matches[0].start;
592            end = info.matches[0].end;
593            Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
594    
595            /*
596             * Append the subSpec argument to the variable, making appropriate
597             * substitutions.  This code is a bit hairy because of the backslash
598             * conventions and because the code saves up ranges of characters in
599             * subSpec to reduce the number of calls to Tcl_SetVar.
600             */
601    
602            src = subspec;
603            firstChar = subspec;
604            for (c = *src; c != '\0'; src++, c = *src) {
605                int index;
606        
607                if (c == '&') {
608                    index = 0;
609                } else if (c == '\\') {
610                    c = src[1];
611                    if ((c >= '0') && (c <= '9')) {
612                        index = c - '0';
613                    } else if ((c == '\\') || (c == '&')) {
614                        Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
615                        Tcl_AppendToObj(resultPtr, &c, 1);
616                        firstChar = src + 2;
617                        src++;
618                        continue;
619                    } else {
620                        continue;
621                    }
622                } else {
623                    continue;
624                }
625                if (firstChar != src) {
626                    Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
627                }
628                if (index <= info.nsubs) {
629                    subStart = info.matches[index].start;
630                    subEnd = info.matches[index].end;
631                    if ((subStart >= 0) && (subEnd >= 0)) {
632                        Tcl_AppendUnicodeToObj(resultPtr,
633                                wstring + offset + subStart, subEnd - subStart);
634                    }
635                }
636                if (*src == '\\') {
637                    src++;
638                }
639                firstChar = src + 1;
640            }
641            if (firstChar != src) {
642                Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
643            }
644            if (end == 0) {
645                /*
646                 * Always consume at least one character of the input string
647                 * in order to prevent infinite loops.
648                 */
649    
650                Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
651                offset++;
652            }
653            offset += end;
654            if (!all) {
655                break;
656            }
657        }
658    
659        /*
660         * Copy the portion of the source string after the last match to the
661         * result variable.
662         */
663    
664        if (numMatches == 0) {
665            /*
666             * On zero matches, just ignore the offset, since it shouldn't
667             * matter to us in this case, and the user may have skewed it.
668             */
669            Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen);
670        } else if (offset < wlen) {
671            Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
672        }
673        if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) {
674            Tcl_AppendResult(interp, "couldn't set variable \"",
675                    Tcl_GetString(varPtr), "\"", (char *) NULL);
676            result = TCL_ERROR;
677        } else {
678            /*
679             * Set the interpreter's object result to an integer object holding the
680             * number of matches.
681             */
682            
683            Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
684        }
685    
686        done:
687        Tcl_DecrRefCount(resultPtr);
688        return result;
689    }
690    
691    /*
692     *----------------------------------------------------------------------
693     *
694     * Tcl_RenameObjCmd --
695     *
696     *      This procedure is invoked to process the "rename" Tcl command.
697     *      See the user documentation for details on what it does.
698     *
699     * Results:
700     *      A standard Tcl object result.
701     *
702     * Side effects:
703     *      See the user documentation.
704     *
705     *----------------------------------------------------------------------
706     */
707    
708            /* ARGSUSED */
709    int
710    Tcl_RenameObjCmd(dummy, interp, objc, objv)
711        ClientData dummy;           /* Arbitrary value passed to the command. */
712        Tcl_Interp *interp;         /* Current interpreter. */
713        int objc;                   /* Number of arguments. */
714        Tcl_Obj *CONST objv[];      /* Argument objects. */
715    {
716        char *oldName, *newName;
717        
718        if (objc != 3) {
719            Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
720            return TCL_ERROR;
721        }
722    
723        oldName = Tcl_GetString(objv[1]);
724        newName = Tcl_GetString(objv[2]);
725        return TclRenameCommand(interp, oldName, newName);
726    }
727    
728    /*
729     *----------------------------------------------------------------------
730     *
731     * Tcl_ReturnObjCmd --
732     *
733     *      This object-based procedure is invoked to process the "return" Tcl
734     *      command. See the user documentation for details on what it does.
735     *
736     * Results:
737     *      A standard Tcl object result.
738     *
739     * Side effects:
740     *      See the user documentation.
741     *
742     *----------------------------------------------------------------------
743     */
744    
745            /* ARGSUSED */
746    int
747    Tcl_ReturnObjCmd(dummy, interp, objc, objv)
748        ClientData dummy;           /* Not used. */
749        Tcl_Interp *interp;         /* Current interpreter. */
750        int objc;                   /* Number of arguments. */
751        Tcl_Obj *CONST objv[];      /* Argument objects. */
752    {
753        Interp *iPtr = (Interp *) interp;
754        int optionLen, argLen, code, result;
755    
756        if (iPtr->errorInfo != NULL) {
757            ckfree(iPtr->errorInfo);
758            iPtr->errorInfo = NULL;
759        }
760        if (iPtr->errorCode != NULL) {
761            ckfree(iPtr->errorCode);
762            iPtr->errorCode = NULL;
763        }
764        code = TCL_OK;
765        
766        for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
767            char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
768            char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
769            
770            if (strcmp(option, "-code") == 0) {
771                register int c = arg[0];
772                if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
773                    code = TCL_OK;
774                } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
775                    code = TCL_ERROR;
776                } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
777                    code = TCL_RETURN;
778                } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
779                    code = TCL_BREAK;
780                } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
781                    code = TCL_CONTINUE;
782                } else {
783                    result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
784                            &code);
785                    if (result != TCL_OK) {
786                        Tcl_ResetResult(interp);
787                        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
788                                "bad completion code \"",
789                                Tcl_GetString(objv[1]),
790                                "\": must be ok, error, return, break, ",
791                                "continue, or an integer", (char *) NULL);
792                        return result;
793                    }
794                }
795            } else if (strcmp(option, "-errorinfo") == 0) {
796                iPtr->errorInfo =
797                    (char *) ckalloc((unsigned) (strlen(arg) + 1));
798                strcpy(iPtr->errorInfo, arg);
799            } else if (strcmp(option, "-errorcode") == 0) {
800                iPtr->errorCode =
801                    (char *) ckalloc((unsigned) (strlen(arg) + 1));
802                strcpy(iPtr->errorCode, arg);
803            } else {
804                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
805                        "bad option \"", option,
806                        "\": must be -code, -errorcode, or -errorinfo",
807                        (char *) NULL);
808                return TCL_ERROR;
809            }
810        }
811        
812        if (objc == 1) {
813            /*
814             * Set the interpreter's object result. An inline version of
815             * Tcl_SetObjResult.
816             */
817    
818            Tcl_SetObjResult(interp, objv[0]);
819        }
820        iPtr->returnCode = code;
821        return TCL_RETURN;
822    }
823    
824    /*
825     *----------------------------------------------------------------------
826     *
827     * Tcl_SourceObjCmd --
828     *
829     *      This procedure is invoked to process the "source" Tcl command.
830     *      See the user documentation for details on what it does.
831     *
832     * Results:
833     *      A standard Tcl object result.
834     *
835     * Side effects:
836     *      See the user documentation.
837     *
838     *----------------------------------------------------------------------
839     */
840    
841            /* ARGSUSED */
842    int
843    Tcl_SourceObjCmd(dummy, interp, objc, objv)
844        ClientData dummy;           /* Not used. */
845        Tcl_Interp *interp;         /* Current interpreter. */
846        int objc;                   /* Number of arguments. */
847        Tcl_Obj *CONST objv[];      /* Argument objects. */
848    {
849        char *bytes;
850        int result;
851        
852        if (objc != 2) {
853            Tcl_WrongNumArgs(interp, 1, objv, "fileName");
854            return TCL_ERROR;
855        }
856    
857        bytes = Tcl_GetString(objv[1]);
858        result = Tcl_EvalFile(interp, bytes);
859        return result;
860    }
861    
862    /*
863     *----------------------------------------------------------------------
864     *
865     * Tcl_SplitObjCmd --
866     *
867     *      This procedure is invoked to process the "split" Tcl command.
868     *      See the user documentation for details on what it does.
869     *
870     * Results:
871     *      A standard Tcl result.
872     *
873     * Side effects:
874     *      See the user documentation.
875     *
876     *----------------------------------------------------------------------
877     */
878    
879            /* ARGSUSED */
880    int
881    Tcl_SplitObjCmd(dummy, interp, objc, objv)
882        ClientData dummy;           /* Not used. */
883        Tcl_Interp *interp;         /* Current interpreter. */
884        int objc;                   /* Number of arguments. */
885        Tcl_Obj *CONST objv[];      /* Argument objects. */
886    {
887        Tcl_UniChar ch;
888        int len;
889        char *splitChars, *string, *end;
890        int splitCharLen, stringLen;
891        Tcl_Obj *listPtr, *objPtr;
892    
893        if (objc == 2) {
894            splitChars = " \n\t\r";
895            splitCharLen = 4;
896        } else if (objc == 3) {
897            splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
898        } else {
899            Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
900            return TCL_ERROR;
901        }
902    
903        string = Tcl_GetStringFromObj(objv[1], &stringLen);
904        end = string + stringLen;
905        listPtr = Tcl_GetObjResult(interp);
906        
907        if (stringLen == 0) {
908            /*
909             * Do nothing.
910             */
911        } else if (splitCharLen == 0) {
912            /*
913             * Handle the special case of splitting on every character.
914             */
915    
916            for ( ; string < end; string += len) {
917                len = Tcl_UtfToUniChar(string, &ch);
918                objPtr = Tcl_NewStringObj(string, len);
919                Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
920            }
921        } else {
922            char *element, *p, *splitEnd;
923            int splitLen;
924            Tcl_UniChar splitChar;
925            
926            /*
927             * Normal case: split on any of a given set of characters.
928             * Discard instances of the split characters.
929             */
930    
931            splitEnd = splitChars + splitCharLen;
932    
933            for (element = string; string < end; string += len) {
934                len = Tcl_UtfToUniChar(string, &ch);
935                for (p = splitChars; p < splitEnd; p += splitLen) {
936                    splitLen = Tcl_UtfToUniChar(p, &splitChar);
937                    if (ch == splitChar) {
938                        objPtr = Tcl_NewStringObj(element, string - element);
939                        Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
940                        element = string + len;
941                        break;
942                    }
943                }
944            }
945            objPtr = Tcl_NewStringObj(element, string - element);
946            Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
947        }
948        return TCL_OK;
949    }
950    
951    /*
952     *----------------------------------------------------------------------
953     *
954     * Tcl_StringObjCmd --
955     *
956     *      This procedure is invoked to process the "string" Tcl command.
957     *      See the user documentation for details on what it does.  Note
958     *      that this command only functions correctly on properly formed
959     *      Tcl UTF strings.
960     *
961     * Results:
962     *      A standard Tcl result.
963     *
964     * Side effects:
965     *      See the user documentation.
966     *
967     *----------------------------------------------------------------------
968     */
969    
970            /* ARGSUSED */
971    int
972    Tcl_StringObjCmd(dummy, interp, objc, objv)
973        ClientData dummy;           /* Not used. */
974        Tcl_Interp *interp;         /* Current interpreter. */
975        int objc;                   /* Number of arguments. */
976        Tcl_Obj *CONST objv[];      /* Argument objects. */
977    {
978        int index, left, right;
979        Tcl_Obj *resultPtr;
980        char *string1, *string2;
981        int length1, length2;
982        static char *options[] = {
983            "bytelength",   "compare",      "equal",        "first",
984            "index",        "is",           "last",         "length",
985            "map",          "match",        "range",        "repeat",
986            "replace",      "tolower",      "toupper",      "totitle",
987            "trim",         "trimleft",     "trimright",
988            "wordend",      "wordstart",    (char *) NULL
989        };
990        enum options {
991            STR_BYTELENGTH, STR_COMPARE,    STR_EQUAL,      STR_FIRST,
992            STR_INDEX,      STR_IS,         STR_LAST,       STR_LENGTH,
993            STR_MAP,        STR_MATCH,      STR_RANGE,      STR_REPEAT,
994            STR_REPLACE,    STR_TOLOWER,    STR_TOUPPER,    STR_TOTITLE,
995            STR_TRIM,       STR_TRIMLEFT,   STR_TRIMRIGHT,
996            STR_WORDEND,    STR_WORDSTART
997        };    
998    
999        if (objc < 2) {
1000            Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1001            return TCL_ERROR;
1002        }
1003        
1004        if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1005                &index) != TCL_OK) {
1006            return TCL_ERROR;
1007        }
1008    
1009        resultPtr = Tcl_GetObjResult(interp);
1010        switch ((enum options) index) {
1011            case STR_EQUAL:
1012            case STR_COMPARE: {
1013                int i, match, length, nocase = 0, reqlength = -1;
1014    
1015                if (objc < 4 || objc > 7) {
1016                str_cmp_args:
1017                    Tcl_WrongNumArgs(interp, 2, objv,
1018                                     "?-nocase? ?-length int? string1 string2");
1019                    return TCL_ERROR;
1020                }
1021    
1022                for (i = 2; i < objc-2; i++) {
1023                    string2 = Tcl_GetStringFromObj(objv[i], &length2);
1024                    if ((length2 > 1)
1025                            && strncmp(string2, "-nocase", (size_t) length2) == 0) {
1026                        nocase = 1;
1027                    } else if ((length2 > 1)
1028                            && strncmp(string2, "-length", (size_t) length2) == 0) {
1029                        if (i+1 >= objc-2) {
1030                            goto str_cmp_args;
1031                        }
1032                        if (Tcl_GetIntFromObj(interp, objv[++i],
1033                                &reqlength) != TCL_OK) {
1034                            return TCL_ERROR;
1035                        }
1036                    } else {
1037                        Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1038                                string2, "\": must be -nocase or -length",
1039                                (char *) NULL);
1040                        return TCL_ERROR;
1041                    }
1042                }
1043    
1044                string1 = Tcl_GetStringFromObj(objv[objc-2], &length1);
1045                string2 = Tcl_GetStringFromObj(objv[objc-1], &length2);
1046                /*
1047                 * This is the min length IN BYTES of the two strings
1048                 */
1049                length = (length1 < length2) ? length1 : length2;
1050    
1051                if (reqlength == 0) {
1052                    /*
1053                     * Anything matches at 0 chars, right?
1054                     */
1055    
1056                    match = 0;
1057                } else if (nocase || ((reqlength > 0) && (reqlength <= length))) {
1058                    /*
1059                     * with -nocase or -length we have to check true char length
1060                     * as it could be smaller than expected
1061                     */
1062    
1063                    length1 = Tcl_NumUtfChars(string1, length1);
1064                    length2 = Tcl_NumUtfChars(string2, length2);
1065                    length = (length1 < length2) ? length1 : length2;
1066    
1067                    /*
1068                     * Do the reqlength check again, against 0 as well for
1069                     * the benfit of nocase
1070                     */
1071    
1072                    if ((reqlength > 0) && (reqlength < length)) {
1073                        length = reqlength;
1074                    } else if (reqlength < 0) {
1075                        /*
1076                         * The requested length is negative, so we ignore it by
1077                         * setting it to the longer of the two lengths.
1078                         */
1079    
1080                        reqlength = (length1 > length2) ? length1 : length2;
1081                    }
1082                    if (nocase) {
1083                        match = Tcl_UtfNcasecmp(string1, string2,
1084                                (unsigned) length);
1085                    } else {
1086                        match = Tcl_UtfNcmp(string1, string2, (unsigned) length);
1087                    }
1088                    if ((match == 0) && (reqlength > length)) {
1089                        match = length1 - length2;
1090                    }
1091                } else {
1092                    match = memcmp(string1, string2, (unsigned) length);
1093                    if (match == 0) {
1094                        match = length1 - length2;
1095                    }
1096                }
1097    
1098                if ((enum options) index == STR_EQUAL) {
1099                    Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
1100                } else {
1101                    Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
1102                                              (match < 0) ? -1 : 0));
1103                }
1104                break;
1105            }
1106            case STR_FIRST: {
1107                register char *p, *end;
1108                int match, utflen, start;
1109    
1110                if (objc < 4 || objc > 5) {
1111                    Tcl_WrongNumArgs(interp, 2, objv,
1112                                     "string1 string2 ?startIndex?");
1113                    return TCL_ERROR;
1114                }
1115    
1116                /*
1117                 * This algorithm fails on improperly formed UTF strings.
1118                 * We are searching string2 for the sequence string1.
1119                 */
1120    
1121                match = -1;
1122                start = 0;
1123                utflen = -1;
1124                string1 = Tcl_GetStringFromObj(objv[2], &length1);
1125                string2 = Tcl_GetStringFromObj(objv[3], &length2);
1126    
1127                if (objc == 5) {
1128                    /*
1129                     * If a startIndex is specified, we will need to fast forward
1130                     * to that point in the string before we think about a match
1131                     */
1132                    utflen = Tcl_NumUtfChars(string2, length2);
1133                    if (TclGetIntForIndex(interp, objv[4], utflen-1,
1134                                          &start) != TCL_OK) {
1135                        return TCL_ERROR;
1136                    }
1137                    if (start >= utflen) {
1138                        goto str_first_done;
1139                    } else if (start > 0) {
1140                        if (length2 == utflen) {
1141                            /* no unicode chars */
1142                            string2 += start;
1143                            length2 -= start;
1144                        } else {
1145                            char *s = Tcl_UtfAtIndex(string2, start);
1146                            length2 -= s - string2;
1147                            string2 = s;
1148                        }
1149                    }
1150                }
1151    
1152                if (length1 > 0) {
1153                    end = string2 + length2 - length1 + 1;
1154                    for (p = string2;  p < end;  p++) {
1155                        /*
1156                         * Scan forward to find the first character.
1157                         */
1158    
1159                        p = memchr(p, *string1, (unsigned) (end - p));
1160                        if (p == NULL) {
1161                            break;
1162                        }
1163                        if (memcmp(string1, p, (unsigned) length1) == 0) {
1164                            match = p - string2;
1165                            break;
1166                        }
1167                    }
1168                }
1169    
1170                /*
1171                 * Compute the character index of the matching string by
1172                 * counting the number of characters before the match.
1173                 */
1174            str_first_done:
1175                if (match != -1) {
1176                    if (objc == 4) {
1177                        match = Tcl_NumUtfChars(string2, match);
1178                    } else if (length2 == utflen) {
1179                        /* no unicode chars */
1180                        match += start;
1181                    } else {
1182                        match = start + Tcl_NumUtfChars(string2, match);
1183                    }
1184                }
1185                Tcl_SetIntObj(resultPtr, match);
1186                break;
1187            }
1188            case STR_INDEX: {
1189                char buf[TCL_UTF_MAX];
1190                Tcl_UniChar unichar;
1191    
1192                if (objc != 4) {
1193                    Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
1194                    return TCL_ERROR;
1195                }
1196    
1197                /*
1198                 * If we have a ByteArray object, avoid indexing in the
1199                 * Utf string since the byte array contains one byte per
1200                 * character.  Otherwise, use the Unicode string rep to
1201                 * get the index'th char.
1202                 */
1203    
1204                if (objv[2]->typePtr == &tclByteArrayType) {
1205    
1206                    string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
1207    
1208                    if (TclGetIntForIndex(interp, objv[3], length1 - 1,
1209                            &index) != TCL_OK) {
1210                        return TCL_ERROR;
1211                    }
1212                    Tcl_SetByteArrayObj(resultPtr,
1213                            (unsigned char *)(&string1[index]), 1);
1214                } else {
1215                    string1 = Tcl_GetStringFromObj(objv[2], &length1);
1216                    
1217                    /*
1218                     * convert to Unicode internal rep to calulate what
1219                     * 'end' really means.
1220                     */
1221    
1222                    length2 = Tcl_GetCharLength(objv[2]);
1223        
1224                    if (TclGetIntForIndex(interp, objv[3], length2 - 1,
1225                            &index) != TCL_OK) {
1226                        return TCL_ERROR;
1227                    }
1228                    if ((index >= 0) && (index < length2)) {
1229                        unichar = Tcl_GetUniChar(objv[2], index);
1230                        length2 = Tcl_UniCharToUtf((int)unichar, buf);
1231                        Tcl_SetStringObj(resultPtr, buf, length2);
1232                    }
1233                }
1234                break;
1235            }
1236            case STR_IS: {
1237                char *end;
1238                Tcl_UniChar ch;
1239    
1240                /*
1241                 * The UniChar comparison function
1242                 */
1243    
1244                int (*chcomp)_ANSI_ARGS_((int)) = NULL;
1245                int i, failat = 0, result = 1, strict = 0;
1246                Tcl_Obj *objPtr, *failVarObj = NULL;
1247    
1248                static char *isOptions[] = {
1249                    "alnum",        "alpha",        "ascii",        "control",
1250                    "boolean",      "digit",        "double",       "false",
1251                    "graph",        "integer",      "lower",        "print",
1252                    "punct",        "space",        "true",         "upper",
1253                    "wordchar",     "xdigit",       (char *) NULL
1254                };
1255                enum isOptions {
1256                    STR_IS_ALNUM,   STR_IS_ALPHA,   STR_IS_ASCII,   STR_IS_CONTROL,
1257                    STR_IS_BOOL,    STR_IS_DIGIT,   STR_IS_DOUBLE,  STR_IS_FALSE,
1258                    STR_IS_GRAPH,   STR_IS_INT,     STR_IS_LOWER,   STR_IS_PRINT,
1259                    STR_IS_PUNCT,   STR_IS_SPACE,   STR_IS_TRUE,    STR_IS_UPPER,
1260                    STR_IS_WORD,    STR_IS_XDIGIT
1261                };
1262    
1263                if (objc < 4 || objc > 7) {
1264                    Tcl_WrongNumArgs(interp, 2, objv,
1265                                     "class ?-strict? ?-failindex var? str");
1266                    return TCL_ERROR;
1267                }
1268                if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
1269                                        &index) != TCL_OK) {
1270                    return TCL_ERROR;
1271                }
1272                if (objc != 4) {
1273                    for (i = 3; i < objc-1; i++) {
1274                        string2 = Tcl_GetStringFromObj(objv[i], &length2);
1275                        if ((length2 > 1) &&
1276                            strncmp(string2, "-strict", (size_t) length2) == 0) {
1277                            strict = 1;
1278                        } else if ((length2 > 1) &&
1279                                   strncmp(string2, "-failindex", (size_t) length2) == 0) {
1280                            if (i+1 >= objc-1) {
1281                                Tcl_WrongNumArgs(interp, 3, objv,
1282                                                 "?-strict? ?-failindex var? str");
1283                                return TCL_ERROR;
1284                            }
1285                            failVarObj = objv[++i];
1286                        } else {
1287                            Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1288                                    string2, "\": must be -strict or -failindex",
1289                                    (char *) NULL);
1290                            return TCL_ERROR;
1291                        }
1292                    }
1293                }
1294    
1295                /*
1296                 * We get the objPtr so that we can short-cut for some classes
1297                 * by checking the object type (int and double), but we need
1298                 * the string otherwise, because we don't want any conversion
1299                 * of type occuring (as, for example, Tcl_Get*FromObj would do
1300                 */
1301                objPtr = objv[objc-1];
1302                string1 = Tcl_GetStringFromObj(objPtr, &length1);
1303                if (length1 == 0) {
1304                    if (strict) {
1305                        result = 0;
1306                    }
1307                    goto str_is_done;
1308                }
1309                end = string1 + length1;
1310    
1311                /*
1312                 * When entering here, result == 1 and failat == 0
1313                 */
1314                switch ((enum isOptions) index) {
1315                    case STR_IS_ALNUM:
1316                        chcomp = Tcl_UniCharIsAlnum;
1317                        break;
1318                    case STR_IS_ALPHA:
1319                        chcomp = Tcl_UniCharIsAlpha;
1320                        break;
1321                    case STR_IS_ASCII:
1322                        for (; string1 < end; string1++, failat++) {
1323                            /*
1324                             * This is a valid check in unicode, because all
1325                             * bytes < 0xC0 are single byte chars (but isascii
1326                             * limits that def'n to 0x80).
1327                             */
1328                            if (*((unsigned char *)string1) >= 0x80) {
1329                                result = 0;
1330                                break;
1331                            }
1332                        }
1333                        break;
1334                    case STR_IS_BOOL:
1335                    case STR_IS_TRUE:
1336                    case STR_IS_FALSE:
1337                        if (objPtr->typePtr == &tclBooleanType) {
1338                            if ((((enum isOptions) index == STR_IS_TRUE) &&
1339                                 objPtr->internalRep.longValue == 0) ||
1340                                (((enum isOptions) index == STR_IS_FALSE) &&
1341                                 objPtr->internalRep.longValue != 0)) {
1342                                result = 0;
1343                            }
1344                        } else if ((Tcl_GetBoolean(NULL, string1, &i)
1345                                    == TCL_ERROR) ||
1346                                   (((enum isOptions) index == STR_IS_TRUE) &&
1347                                    i == 0) ||
1348                                   (((enum isOptions) index == STR_IS_FALSE) &&
1349                                    i != 0)) {
1350                            result = 0;
1351                        }
1352                        break;
1353                    case STR_IS_CONTROL:
1354                        chcomp = Tcl_UniCharIsControl;
1355                        break;
1356                    case STR_IS_DIGIT:
1357                        chcomp = Tcl_UniCharIsDigit;
1358                        break;
1359                    case STR_IS_DOUBLE: {
1360                        char *stop;
1361    
1362                        if ((objPtr->typePtr == &tclDoubleType) ||
1363                            (objPtr->typePtr == &tclIntType)) {
1364                            break;
1365                        }
1366                        /*
1367                         * This is adapted from Tcl_GetDouble
1368                         *
1369                         * The danger in this function is that
1370                         * "12345678901234567890" is an acceptable 'double',
1371                         * but will later be interp'd as an int by something
1372                         * like [expr].  Therefore, we check to see if it looks
1373                         * like an int, and if so we do a range check on it.
1374                         * If strtoul gets to the end, we know we either
1375                         * received an acceptable int, or over/underflow
1376                         */
1377                        if (TclLooksLikeInt(string1, length1)) {
1378                            errno = 0;
1379                            strtoul(string1, &stop, 0);
1380                            if (stop == end) {
1381                                if (errno == ERANGE) {
1382                                    result = 0;
1383                                    failat = -1;
1384                                }
1385                                break;
1386                            }
1387                        }
1388                        errno = 0;
1389                        strtod(string1, &stop); /* INTL: Tcl source. */
1390                        if (errno == ERANGE) {
1391                            /*
1392                             * if (errno == ERANGE), then it was an over/underflow
1393                             * problem, but in this method, we only want to know
1394                             * yes or no, so bad flow returns 0 (false) and sets
1395                             * the failVarObj to the string length.
1396                             */
1397                            result = 0;
1398                            failat = -1;
1399                        } else if (stop == string1) {
1400                            /*
1401                             * In this case, nothing like a number was found
1402                             */
1403                            result = 0;
1404                            failat = 0;
1405                        } else {
1406                            /*
1407                             * Assume we sucked up one char per byte
1408                             * and then we go onto SPACE, since we are
1409                             * allowed trailing whitespace
1410                             */
1411                            failat = stop - string1;
1412                            string1 = stop;
1413                            chcomp = Tcl_UniCharIsSpace;
1414                        }
1415                        break;
1416                    }
1417                    case STR_IS_GRAPH:
1418                        chcomp = Tcl_UniCharIsGraph;
1419                        break;
1420                    case STR_IS_INT: {
1421                        char *stop;
1422    
1423                        if ((objPtr->typePtr == &tclIntType) ||
1424                            (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
1425                            break;
1426                        }
1427                        /*
1428                         * Like STR_IS_DOUBLE, but we use strtoul.
1429                         * Since Tcl_GetInt already failed, we set result to 0.
1430                         */
1431                        result = 0;
1432                        errno = 0;
1433                        strtoul(string1, &stop, 0); /* INTL: Tcl source. */
1434                        if (errno == ERANGE) {
1435                            /*
1436                             * if (errno == ERANGE), then it was an over/underflow
1437                             * problem, but in this method, we only want to know
1438                             * yes or no, so bad flow returns 0 (false) and sets
1439                             * the failVarObj to the string length.
1440                             */
1441                            failat = -1;
1442                        } else if (stop == string1) {
1443                            /*
1444                             * In this case, nothing like a number was found
1445                             */
1446                            failat = 0;
1447                        } else {
1448                            /*
1449                             * Assume we sucked up one char per byte
1450                             * and then we go onto SPACE, since we are
1451                             * allowed trailing whitespace
1452                             */
1453                            failat = stop - string1;
1454                            string1 = stop;
1455                            chcomp = Tcl_UniCharIsSpace;
1456                        }
1457                        break;
1458                    }
1459                    case STR_IS_LOWER:
1460                        chcomp = Tcl_UniCharIsLower;
1461                        break;
1462                    case STR_IS_PRINT:
1463                        chcomp = Tcl_UniCharIsPrint;
1464                        break;
1465                    case STR_IS_PUNCT:
1466                        chcomp = Tcl_UniCharIsPunct;
1467                        break;
1468                    case STR_IS_SPACE:
1469                        chcomp = Tcl_UniCharIsSpace;
1470                        break;
1471                    case STR_IS_UPPER:
1472                        chcomp = Tcl_UniCharIsUpper;
1473                        break;
1474                    case STR_IS_WORD:
1475                        chcomp = Tcl_UniCharIsWordChar;
1476                        break;
1477                    case STR_IS_XDIGIT: {
1478                        for (; string1 < end; string1++, failat++) {
1479                            /* INTL: We assume unicode is bad for this class */
1480                            if ((*((unsigned char *)string1) >= 0xC0) ||
1481                                !isxdigit(*(unsigned char *)string1)) {
1482                                result = 0;
1483                                break;
1484                            }
1485                        }
1486                        break;
1487                    }
1488                }
1489                if (chcomp != NULL) {
1490                    for (; string1 < end; string1 += length2, failat++) {
1491                        length2 = Tcl_UtfToUniChar(string1, &ch);
1492                        if (!chcomp(ch)) {
1493                            result = 0;
1494                            break;
1495                        }
1496                    }
1497                }
1498            str_is_done:
1499                /*
1500                 * Only set the failVarObj when we will return 0
1501                 * and we have indicated a valid fail index (>= 0)
1502                 */
1503                if ((result == 0) && (failVarObj != NULL) &&
1504                    Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
1505                                   TCL_LEAVE_ERR_MSG) == NULL) {
1506                    return TCL_ERROR;
1507                }
1508                Tcl_SetBooleanObj(resultPtr, result);
1509                break;
1510            }
1511            case STR_LAST: {
1512                register char *p;
1513                int match, utflen, start;
1514    
1515                if (objc < 4 || objc > 5) {
1516                    Tcl_WrongNumArgs(interp, 2, objv,
1517                                     "string1 string2 ?startIndex?");
1518                    return TCL_ERROR;
1519                }
1520    
1521                /*
1522                 * This algorithm fails on improperly formed UTF strings.
1523                 */
1524    
1525                match = -1;
1526                start = 0;
1527                utflen = -1;
1528                string1 = Tcl_GetStringFromObj(objv[2], &length1);
1529                string2 = Tcl_GetStringFromObj(objv[3], &length2);
1530    
1531                if (objc == 5) {
1532                    /*
1533                     * If a startIndex is specified, we will need to restrict
1534                     * the string range to that char index in the string
1535                     */
1536                    utflen = Tcl_NumUtfChars(string2, length2);
1537                    if (TclGetIntForIndex(interp, objv[4], utflen-1,
1538                                          &start) != TCL_OK) {
1539                        return TCL_ERROR;
1540                    }
1541                    if (start < 0) {
1542                        goto str_last_done;
1543                    } else if (start < utflen) {
1544                        if (length2 == utflen) {
1545                            /* no unicode chars */
1546                            p = string2 + start + 1 - length1;
1547                        } else {
1548                            p = Tcl_UtfAtIndex(string2, start+1) - length1;
1549                        }
1550                    } else {
1551                        p = string2 + length2 - length1;
1552                    }
1553                } else {
1554                    p = string2 + length2 - length1;
1555                }
1556    
1557                if (length1 > 0) {
1558                    for (;  p >= string2;  p--) {
1559                        /*
1560                         * Scan backwards to find the first character.
1561                         */
1562    
1563                        while ((p != string2) && (*p != *string1)) {
1564                            p--;
1565                        }
1566                        if (memcmp(string1, p, (unsigned) length1) == 0) {
1567                            match = p - string2;
1568                            break;
1569                        }
1570                    }
1571                }
1572    
1573                /*
1574                 * Compute the character index of the matching string by counting
1575                 * the number of characters before the match.
1576                 */
1577            str_last_done:
1578                if (match != -1) {
1579                    if ((objc == 4) || (length2 != utflen)) {
1580                        /* only check when we've got unicode chars */
1581                        match = Tcl_NumUtfChars(string2, match);
1582                    }
1583                }
1584                Tcl_SetIntObj(resultPtr, match);
1585                break;
1586            }
1587            case STR_BYTELENGTH:
1588            case STR_LENGTH: {
1589                if (objc != 3) {
1590                    Tcl_WrongNumArgs(interp, 2, objv, "string");
1591                    return TCL_ERROR;
1592                }
1593    
1594                if ((enum options) index == STR_BYTELENGTH) {
1595                    (void) Tcl_GetStringFromObj(objv[2], &length1);