Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 396c145dddedc7d092cf702dac0d1646837967a5:


     1  /* 
     2   * tclCmdMZ.c --
     3   *
     4   *	This file contains the top-level command routines for most of
     5   *	the Tcl built-in commands whose names begin with the letters
     6   *	M to Z.  It contains only commands in the generic core (i.e.
     7   *	those that don't depend much upon UNIX facilities).
     8   *
     9   * Copyright (c) 1987-1993 The Regents of the University of California.
    10   * Copyright (c) 1994-1997 Sun Microsystems, Inc.
    11   * Copyright (c) 1998-2000 Scriptics Corporation.
    12   * Copyright (c) 2002 ActiveState Corporation.
    13   * Copyright (c) 2003 Donal K. Fellows.
    14   *
    15   * See the file "license.terms" for information on usage and redistribution
    16   * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    17   *
    18   * RCS: @(#) $Id: tclCmdMZ.c,v 1.97 2003/12/14 18:32:36 dkf Exp $
    19   */
    20  
    21  #include "tclInt.h"
    22  #include "tclPort.h"
    23  #include "tclRegexp.h"
    24  
    25  /*
    26   *----------------------------------------------------------------------
    27   *
    28   * Tcl_PwdObjCmd --
    29   *
    30   *	This procedure is invoked to process the "pwd" Tcl command.
    31   *	See the user documentation for details on what it does.
    32   *
    33   * Results:
    34   *	A standard Tcl result.
    35   *
    36   * Side effects:
    37   *	See the user documentation.
    38   *
    39   *----------------------------------------------------------------------
    40   */
    41  
    42  	/* ARGSUSED */
    43  int
    44  Tcl_PwdObjCmd(dummy, interp, objc, objv)
    45      ClientData dummy;			/* Not used. */
    46      Tcl_Interp *interp;			/* Current interpreter. */
    47      int objc;				/* Number of arguments. */
    48      Tcl_Obj *CONST objv[];		/* Argument objects. */
    49  {
    50      Tcl_Obj *retVal;
    51  
    52      if (objc != 1) {
    53  	Tcl_WrongNumArgs(interp, 1, objv, NULL);
    54  	return TCL_ERROR;
    55      }
    56  
    57      retVal = Tcl_FSGetCwd(interp);
    58      if (retVal == NULL) {
    59  	return TCL_ERROR;
    60      }
    61      Tcl_SetObjResult(interp, retVal);
    62      Tcl_DecrRefCount(retVal);
    63      return TCL_OK;
    64  }
    65  
    66  /*
    67   *----------------------------------------------------------------------
    68   *
    69   * Tcl_RegexpObjCmd --
    70   *
    71   *	This procedure is invoked to process the "regexp" 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_RegexpObjCmd(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      int i, indices, match, about, offset, all, doinline, numMatchesSaved;
    92      int cflags, eflags, stringLength;
    93      Tcl_RegExp regExpr;
    94      Tcl_Obj *objPtr, *resultPtr;
    95      Tcl_RegExpInfo info;
    96      static CONST char *options[] = {
    97  	"-all",		"-about",	"-indices",	"-inline",
    98  	"-expanded",	"-line",	"-linestop",	"-lineanchor",
    99  	"-nocase",	"-start",	"--",		(char *) NULL
   100      };
   101      enum options {
   102  	REGEXP_ALL,	REGEXP_ABOUT,	REGEXP_INDICES,	REGEXP_INLINE,
   103  	REGEXP_EXPANDED,REGEXP_LINE,	REGEXP_LINESTOP,REGEXP_LINEANCHOR,
   104  	REGEXP_NOCASE,	REGEXP_START,	REGEXP_LAST
   105      };
   106  
   107      indices	= 0;
   108      about	= 0;
   109      cflags	= TCL_REG_ADVANCED;
   110      eflags	= 0;
   111      offset	= 0;
   112      all		= 0;
   113      doinline	= 0;
   114      
   115      for (i = 1; i < objc; i++) {
   116  	char *name;
   117  	int index;
   118  
   119  	name = Tcl_GetString(objv[i]);
   120  	if (name[0] != '-') {
   121  	    break;
   122  	}
   123  	if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
   124  		&index) != TCL_OK) {
   125  	    return TCL_ERROR;
   126  	}
   127  	switch ((enum options) index) {
   128  	    case REGEXP_ALL: {
   129  		all = 1;
   130  		break;
   131  	    }
   132  	    case REGEXP_INDICES: {
   133  		indices = 1;
   134  		break;
   135  	    }
   136  	    case REGEXP_INLINE: {
   137  		doinline = 1;
   138  		break;
   139  	    }
   140  	    case REGEXP_NOCASE: {
   141  		cflags |= TCL_REG_NOCASE;
   142  		break;
   143  	    }
   144  	    case REGEXP_ABOUT: {
   145  		about = 1;
   146  		break;
   147  	    }
   148  	    case REGEXP_EXPANDED: {
   149  		cflags |= TCL_REG_EXPANDED;
   150  		break;
   151  	    }
   152  	    case REGEXP_LINE: {
   153  		cflags |= TCL_REG_NEWLINE;
   154  		break;
   155  	    }
   156  	    case REGEXP_LINESTOP: {
   157  		cflags |= TCL_REG_NLSTOP;
   158  		break;
   159  	    }
   160  	    case REGEXP_LINEANCHOR: {
   161  		cflags |= TCL_REG_NLANCH;
   162  		break;
   163  	    }
   164  	    case REGEXP_START: {
   165  		if (++i >= objc) {
   166  		    goto endOfForLoop;
   167  		}
   168  		if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
   169  		    return TCL_ERROR;
   170  		}
   171  		if (offset < 0) {
   172  		    offset = 0;
   173  		}
   174  		break;
   175  	    }
   176  	    case REGEXP_LAST: {
   177  		i++;
   178  		goto endOfForLoop;
   179  	    }
   180  	}
   181      }
   182  
   183      endOfForLoop:
   184      if ((objc - i) < (2 - about)) {
   185  	Tcl_WrongNumArgs(interp, 1, objv, 
   186  	  "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
   187  	return TCL_ERROR;
   188      }
   189      objc -= i;
   190      objv += i;
   191  
   192      if (doinline && ((objc - 2) != 0)) {
   193  	/*
   194  	 * User requested -inline, but specified match variables - a no-no.
   195  	 */
   196  	Tcl_AppendResult(interp, "regexp match variables not allowed",
   197  		" when using -inline", (char *) NULL);
   198  	return TCL_ERROR;
   199      }
   200  
   201      /*
   202       * Handle the odd about case separately.
   203       */
   204      if (about) {
   205  	regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
   206  	if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) {
   207  	    return TCL_ERROR;
   208  	}
   209  	return TCL_OK;
   210      }
   211  
   212      /*
   213       * Get the length of the string that we are matching against so
   214       * we can do the termination test for -all matches.  Do this before
   215       * getting the regexp to avoid shimmering problems.
   216       */
   217      objPtr = objv[1];
   218      stringLength = Tcl_GetCharLength(objPtr);
   219  
   220      regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
   221      if (regExpr == NULL) {
   222  	return TCL_ERROR;
   223      }
   224  
   225      if (offset > 0) {
   226  	/*
   227  	 * Add flag if using offset (string is part of a larger string),
   228  	 * so that "^" won't match.
   229  	 */
   230  	eflags |= TCL_REG_NOTBOL;
   231      }
   232  
   233      objc -= 2;
   234      objv += 2;
   235      resultPtr = Tcl_GetObjResult(interp);
   236  
   237      if (doinline) {
   238  	/*
   239  	 * Save all the subexpressions, as we will return them as a list
   240  	 */
   241  	numMatchesSaved = -1;
   242      } else {
   243  	/*
   244  	 * Save only enough subexpressions for matches we want to keep,
   245  	 * expect in the case of -all, where we need to keep at least
   246  	 * one to know where to move the offset.
   247  	 */
   248  	numMatchesSaved = (objc == 0) ? all : objc;
   249      }
   250  
   251      /*
   252       * The following loop is to handle multiple matches within the
   253       * same source string;  each iteration handles one match.  If "-all"
   254       * hasn't been specified then the loop body only gets executed once.
   255       * We terminate the loop when the starting offset is past the end of the
   256       * string.
   257       */
   258  
   259      while (1) {
   260  	match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
   261  		offset /* offset */, numMatchesSaved, eflags 
   262  		| ((offset > 0 &&
   263  		   (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
   264  		   ? TCL_REG_NOTBOL : 0));
   265  
   266  	if (match < 0) {
   267  	    return TCL_ERROR;
   268  	}
   269  
   270  	if (match == 0) {
   271  	    /*
   272  	     * We want to set the value of the intepreter result only when
   273  	     * this is the first time through the loop.
   274  	     */
   275  	    if (all <= 1) {
   276  		/*
   277  		 * If inlining, set the interpreter's object result to an
   278  		 * empty list, otherwise set it to an integer object w/
   279  		 * value 0.
   280  		 */
   281  		if (doinline) {
   282  		    Tcl_SetListObj(resultPtr, 0, NULL);
   283  		} else {
   284  		    Tcl_SetIntObj(resultPtr, 0);
   285  		}
   286  		return TCL_OK;
   287  	    }
   288  	    break;
   289  	}
   290  
   291  	/*
   292  	 * If additional variable names have been specified, return
   293  	 * index information in those variables.
   294  	 */
   295  
   296  	Tcl_RegExpGetInfo(regExpr, &info);
   297  	if (doinline) {
   298  	    /*
   299  	     * It's the number of substitutions, plus one for the matchVar
   300  	     * at index 0
   301  	     */
   302  	    objc = info.nsubs + 1;
   303  	}
   304  	for (i = 0; i < objc; i++) {
   305  	    Tcl_Obj *newPtr;
   306  
   307  	    if (indices) {
   308  		int start, end;
   309  		Tcl_Obj *objs[2];
   310  
   311  		/*
   312  		 * Only adjust the match area if there was a match for
   313  		 * that area.  (Scriptics Bug 4391/SF Bug #219232)
   314  		 */
   315  		if (i <= info.nsubs && info.matches[i].start >= 0) {
   316  		    start = offset + info.matches[i].start;
   317  		    end   = offset + info.matches[i].end;
   318  
   319  		    /*
   320  		     * Adjust index so it refers to the last character in the
   321  		     * match instead of the first character after the match.
   322  		     */
   323  
   324  		    if (end >= offset) {
   325  			end--;
   326  		    }
   327  		} else {
   328  		    start = -1;
   329  		    end   = -1;
   330  		}
   331  
   332  		objs[0] = Tcl_NewLongObj(start);
   333  		objs[1] = Tcl_NewLongObj(end);
   334  
   335  		newPtr = Tcl_NewListObj(2, objs);
   336  	    } else {
   337  		if (i <= info.nsubs) {
   338  		    newPtr = Tcl_GetRange(objPtr,
   339  			    offset + info.matches[i].start,
   340  			    offset + info.matches[i].end - 1);
   341  		} else {
   342  		    newPtr = Tcl_NewObj();
   343  		}
   344  	    }
   345  	    if (doinline) {
   346  		if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
   347  			!= TCL_OK) {
   348  		    Tcl_DecrRefCount(newPtr);
   349  		    return TCL_ERROR;
   350  		}
   351  	    } else {
   352  		Tcl_Obj *valuePtr;
   353  		valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
   354  		if (valuePtr == NULL) {
   355  		    Tcl_DecrRefCount(newPtr);
   356  		    Tcl_AppendResult(interp, "couldn't set variable \"",
   357  			    Tcl_GetString(objv[i]), "\"", (char *) NULL);
   358  		    return TCL_ERROR;
   359  		}
   360  	    }
   361  	}
   362  
   363  	if (all == 0) {
   364  	    break;
   365  	}
   366  	/*
   367  	 * Adjust the offset to the character just after the last one
   368  	 * in the matchVar and increment all to count how many times
   369  	 * we are making a match.  We always increment the offset by at least
   370  	 * one to prevent endless looping (as in the case:
   371  	 * regexp -all {a*} a).  Otherwise, when we match the NULL string at
   372  	 * the end of the input string, we will loop indefinately (because the
   373  	 * length of the match is 0, so offset never changes).
   374  	 */
   375  	if (info.matches[0].end == 0) {
   376  	    offset++;
   377  	}
   378  	offset += info.matches[0].end;
   379  	all++;
   380  	eflags |= TCL_REG_NOTBOL;
   381  	if (offset >= stringLength) {
   382  	    break;
   383  	}
   384      }
   385  
   386      /*
   387       * Set the interpreter's object result to an integer object
   388       * with value 1 if -all wasn't specified, otherwise it's all-1
   389       * (the number of times through the while - 1).
   390       * Get the resultPtr again as the Tcl_ObjSetVar2 above may have
   391       * cause the result to change. [Patch #558324] (watson).
   392       */
   393  
   394      if (!doinline) {
   395  	resultPtr = Tcl_GetObjResult(interp);
   396  	Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
   397      }
   398      return TCL_OK;
   399  }
   400  
   401  /*
   402   *----------------------------------------------------------------------
   403   *
   404   * Tcl_RegsubObjCmd --
   405   *
   406   *	This procedure is invoked to process the "regsub" Tcl command.
   407   *	See the user documentation for details on what it does.
   408   *
   409   * Results:
   410   *	A standard Tcl result.
   411   *
   412   * Side effects:
   413   *	See the user documentation.
   414   *
   415   *----------------------------------------------------------------------
   416   */
   417  
   418  	/* ARGSUSED */
   419  int
   420  Tcl_RegsubObjCmd(dummy, interp, objc, objv)
   421      ClientData dummy;			/* Not used. */
   422      Tcl_Interp *interp;			/* Current interpreter. */
   423      int objc;				/* Number of arguments. */
   424      Tcl_Obj *CONST objv[];		/* Argument objects. */
   425  {
   426      int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
   427      int start, end, subStart, subEnd, match;
   428      Tcl_RegExp regExpr;
   429      Tcl_RegExpInfo info;
   430      Tcl_Obj *resultPtr, *subPtr, *objPtr;
   431      Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
   432  
   433      static CONST char *options[] = {
   434  	"-all",		"-nocase",	"-expanded",
   435  	"-line",	"-linestop",	"-lineanchor",	"-start",
   436  	"--",		NULL
   437      };
   438      enum options {
   439  	REGSUB_ALL,	REGSUB_NOCASE,	REGSUB_EXPANDED,
   440  	REGSUB_LINE,	REGSUB_LINESTOP, REGSUB_LINEANCHOR,	REGSUB_START,
   441  	REGSUB_LAST
   442      };
   443  
   444      cflags = TCL_REG_ADVANCED;
   445      all = 0;
   446      offset = 0;
   447      resultPtr = NULL;
   448  
   449      for (idx = 1; idx < objc; idx++) {
   450  	char *name;
   451  	int index;
   452  	
   453  	name = Tcl_GetString(objv[idx]);
   454  	if (name[0] != '-') {
   455  	    break;
   456  	}
   457  	if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
   458  		TCL_EXACT, &index) != TCL_OK) {
   459  	    return TCL_ERROR;
   460  	}
   461  	switch ((enum options) index) {
   462  	    case REGSUB_ALL: {
   463  		all = 1;
   464  		break;
   465  	    }
   466  	    case REGSUB_NOCASE: {
   467  		cflags |= TCL_REG_NOCASE;
   468  		break;
   469  	    }
   470  	    case REGSUB_EXPANDED: {
   471  		cflags |= TCL_REG_EXPANDED;
   472  		break;
   473  	    }
   474  	    case REGSUB_LINE: {
   475  		cflags |= TCL_REG_NEWLINE;
   476  		break;
   477  	    }
   478  	    case REGSUB_LINESTOP: {
   479  		cflags |= TCL_REG_NLSTOP;
   480  		break;
   481  	    }
   482  	    case REGSUB_LINEANCHOR: {
   483  		cflags |= TCL_REG_NLANCH;
   484  		break;
   485  	    }
   486  	    case REGSUB_START: {
   487  		if (++idx >= objc) {
   488  		    goto endOfForLoop;
   489  		}
   490  		if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
   491  		    return TCL_ERROR;
   492  		}
   493  		if (offset < 0) {
   494  		    offset = 0;
   495  		}
   496  		break;
   497  	    }
   498  	    case REGSUB_LAST: {
   499  		idx++;
   500  		goto endOfForLoop;
   501  	    }
   502  	}
   503      }
   504      endOfForLoop:
   505      if (objc-idx < 3 || objc-idx > 4) {
   506  	Tcl_WrongNumArgs(interp, 1, objv,
   507  		"?switches? exp string subSpec ?varName?");
   508  	return TCL_ERROR;
   509      }
   510  
   511      objc -= idx;
   512      objv += idx;
   513  
   514      if (all && (offset == 0)
   515  	    && (strpbrk(Tcl_GetString(objv[2]), "&\\") == NULL)
   516  	    && (strpbrk(Tcl_GetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
   517  	/*
   518  	 * This is a simple one pair string map situation.  We make use of
   519  	 * a slightly modified version of the one pair STR_MAP code.
   520  	 */
   521  	int slen, nocase;
   522  	int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *,
   523  		unsigned long));
   524  	Tcl_UniChar *p, wsrclc;
   525  
   526  	numMatches = 0;
   527  	nocase     = (cflags & TCL_REG_NOCASE);
   528  	strCmpFn   = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
   529  
   530  	wsrc     = Tcl_GetUnicodeFromObj(objv[0], &slen);
   531  	wstring  = Tcl_GetUnicodeFromObj(objv[1], &wlen);
   532  	wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
   533  	wend     = wstring + wlen - (slen ? slen - 1 : 0);
   534  	result   = TCL_OK;
   535  
   536  	if (slen == 0) {
   537  	    /*
   538  	     * regsub behavior for "" matches between each character.
   539  	     * 'string map' skips the "" case.
   540  	     */
   541  	    if (wstring < wend) {
   542  		resultPtr = Tcl_NewUnicodeObj(wstring, 0);
   543  		Tcl_IncrRefCount(resultPtr);
   544  		for (; wstring < wend; wstring++) {
   545  		    Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
   546  		    Tcl_AppendUnicodeToObj(resultPtr, wstring, 1);
   547  		    numMatches++;
   548  		}
   549  		wlen = 0;
   550  	    }
   551  	} else {
   552  	    wsrclc = Tcl_UniCharToLower(*wsrc);
   553  	    for (p = wfirstChar = wstring; wstring < wend; wstring++) {
   554  		if (((*wstring == *wsrc) ||
   555  			(nocase && (Tcl_UniCharToLower(*wstring) ==
   556  				wsrclc))) &&
   557  			((slen == 1) || (strCmpFn(wstring, wsrc,
   558  				(unsigned long) slen) == 0))) {
   559  		    if (numMatches == 0) {
   560  			resultPtr = Tcl_NewUnicodeObj(wstring, 0);
   561  			Tcl_IncrRefCount(resultPtr);
   562  		    }
   563  		    if (p != wstring) {
   564  			Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
   565  			p = wstring + slen;
   566  		    } else {
   567  			p += slen;
   568  		    }
   569  		    wstring = p - 1;
   570  
   571  		    Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen);
   572  		    numMatches++;
   573  		}
   574  	    }
   575  	    if (numMatches) {
   576  		wlen    = wfirstChar + wlen - p;
   577  		wstring = p;
   578  	    }
   579  	}
   580  	objPtr = NULL;
   581  	subPtr = NULL;
   582  	goto regsubDone;
   583      }
   584  
   585      regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
   586      if (regExpr == NULL) {
   587  	return TCL_ERROR;
   588      }
   589  
   590      /*
   591       * Make sure to avoid problems where the objects are shared.  This
   592       * can cause RegExpObj <> UnicodeObj shimmering that causes data
   593       * corruption.  [Bug #461322]
   594       */
   595  
   596      if (objv[1] == objv[0]) {
   597  	objPtr = Tcl_DuplicateObj(objv[1]);
   598      } else {
   599  	objPtr = objv[1];
   600      }
   601      wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
   602      if (objv[2] == objv[0]) {
   603  	subPtr = Tcl_DuplicateObj(objv[2]);
   604      } else {
   605  	subPtr = objv[2];
   606      }
   607      wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
   608  
   609      result = TCL_OK;
   610  
   611      /*
   612       * The following loop is to handle multiple matches within the
   613       * same source string;  each iteration handles one match and its
   614       * corresponding substitution.  If "-all" hasn't been specified
   615       * then the loop body only gets executed once.  We must use
   616       * 'offset <= wlen' in particular for the case where the regexp
   617       * pattern can match the empty string - this is useful when
   618       * doing, say, 'regsub -- ^ $str ...' when $str might be empty.
   619       */
   620  
   621      numMatches = 0;
   622      for ( ; offset <= wlen; ) {
   623  
   624  	/*
   625  	 * The flags argument is set if string is part of a larger string,
   626  	 * so that "^" won't match.
   627  	 */
   628  
   629  	match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
   630  		10 /* matches */, ((offset > 0 &&
   631  		   (wstring[offset-1] != (Tcl_UniChar)'\n'))
   632  		   ? TCL_REG_NOTBOL : 0));
   633  
   634  	if (match < 0) {
   635  	    result = TCL_ERROR;
   636  	    goto done;
   637  	}
   638  	if (match == 0) {
   639  	    break;
   640  	}
   641  	if (numMatches == 0) {
   642  	    resultPtr = Tcl_NewUnicodeObj(wstring, 0);
   643  	    Tcl_IncrRefCount(resultPtr);
   644  	    if (offset > 0) {
   645  		/*
   646  		 * Copy the initial portion of the string in if an offset
   647  		 * was specified.
   648  		 */
   649  		Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
   650  	    }
   651  	}
   652  	numMatches++;
   653  
   654  	/*
   655  	 * Copy the portion of the source string before the match to the
   656  	 * result variable.
   657  	 */
   658  
   659  	Tcl_RegExpGetInfo(regExpr, &info);
   660  	start = info.matches[0].start;
   661  	end = info.matches[0].end;
   662  	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
   663  
   664  	/*
   665  	 * Append the subSpec argument to the variable, making appropriate
   666  	 * substitutions.  This code is a bit hairy because of the backslash
   667  	 * conventions and because the code saves up ranges of characters in
   668  	 * subSpec to reduce the number of calls to Tcl_SetVar.
   669  	 */
   670  
   671  	wsrc = wfirstChar = wsubspec;
   672  	wend = wsubspec + wsublen;
   673  	for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) {
   674  	    if (ch == '&') {
   675  		idx = 0;
   676  	    } else if (ch == '\\') {
   677  		ch = wsrc[1];
   678  		if ((ch >= '0') && (ch <= '9')) {
   679  		    idx = ch - '0';
   680  		} else if ((ch == '\\') || (ch == '&')) {
   681  		    *wsrc = ch;
   682  		    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
   683  			    wsrc - wfirstChar + 1);
   684  		    *wsrc = '\\';
   685  		    wfirstChar = wsrc + 2;
   686  		    wsrc++;
   687  		    continue;
   688  		} else {
   689  		    continue;
   690  		}
   691  	    } else {
   692  		continue;
   693  	    }
   694  	    if (wfirstChar != wsrc) {
   695  		Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
   696  			wsrc - wfirstChar);
   697  	    }
   698  	    if (idx <= info.nsubs) {
   699  		subStart = info.matches[idx].start;
   700  		subEnd = info.matches[idx].end;
   701  		if ((subStart >= 0) && (subEnd >= 0)) {
   702  		    Tcl_AppendUnicodeToObj(resultPtr,
   703  			    wstring + offset + subStart, subEnd - subStart);
   704  		}
   705  	    }
   706  	    if (*wsrc == '\\') {
   707  		wsrc++;
   708  	    }
   709  	    wfirstChar = wsrc + 1;
   710  	}
   711  	if (wfirstChar != wsrc) {
   712  	    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
   713  	}
   714  	if (end == 0) {
   715  	    /*
   716  	     * Always consume at least one character of the input string
   717  	     * in order to prevent infinite loops.
   718  	     */
   719  
   720  	    if (offset < wlen) {
   721  		Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
   722  	    }
   723  	    offset++;
   724  	} else {
   725  	    offset += end;
   726  	    if (start == end) {
   727  		/*
   728  		 * We matched an empty string, which means we must go 
   729  		 * forward one more step so we don't match again at the
   730  		 * same spot.
   731  		 */
   732  		if (offset < wlen) {
   733  		    Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
   734  		}
   735  		offset++;
   736  	    }
   737  	}
   738  	if (!all) {
   739  	    break;
   740  	}
   741      }
   742  
   743      /*
   744       * Copy the portion of the source string after the last match to the
   745       * result variable.
   746       */
   747      regsubDone:
   748      if (numMatches == 0) {
   749  	/*
   750  	 * On zero matches, just ignore the offset, since it shouldn't
   751  	 * matter to us in this case, and the user may have skewed it.
   752  	 */
   753  	resultPtr = objv[1];
   754  	Tcl_IncrRefCount(resultPtr);
   755      } else if (offset < wlen) {
   756  	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
   757      }
   758      if (objc == 4) {
   759  	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
   760  	    Tcl_AppendResult(interp, "couldn't set variable \"",
   761  		    Tcl_GetString(objv[3]), "\"", (char *) NULL);
   762  	    result = TCL_ERROR;
   763  	} else {
   764  	    /*
   765  	     * Set the interpreter's object result to an integer object
   766  	     * holding the number of matches. 
   767  	     */
   768  
   769  	    Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
   770  	}
   771      } else {
   772  	/*
   773  	 * No varname supplied, so just return the modified string.
   774  	 */
   775  	Tcl_SetObjResult(interp, resultPtr);
   776      }
   777  
   778      done:
   779      if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); }
   780      if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); }
   781      if (resultPtr) { Tcl_DecrRefCount(resultPtr); }
   782      return result;
   783  }
   784  
   785  /*
   786   *----------------------------------------------------------------------
   787   *
   788   * Tcl_RenameObjCmd --
   789   *
   790   *	This procedure is invoked to process the "rename" Tcl command.
   791   *	See the user documentation for details on what it does.
   792   *
   793   * Results:
   794   *	A standard Tcl object result.
   795   *
   796   * Side effects:
   797   *	See the user documentation.
   798   *
   799   *----------------------------------------------------------------------
   800   */
   801  
   802  	/* ARGSUSED */
   803  int
   804  Tcl_RenameObjCmd(dummy, interp, objc, objv)
   805      ClientData dummy;		/* Arbitrary value passed to the command. */
   806      Tcl_Interp *interp;		/* Current interpreter. */
   807      int objc;			/* Number of arguments. */
   808      Tcl_Obj *CONST objv[];	/* Argument objects. */
   809  {
   810      char *oldName, *newName;
   811      
   812      if (objc != 3) {
   813  	Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
   814  	return TCL_ERROR;
   815      }
   816  
   817      oldName = Tcl_GetString(objv[1]);
   818      newName = Tcl_GetString(objv[2]);
   819      return TclRenameCommand(interp, oldName, newName);
   820  }
   821  
   822  /*
   823   *----------------------------------------------------------------------
   824   *
   825   * Tcl_ReturnObjCmd --
   826   *
   827   *	This object-based procedure is invoked to process the "return" Tcl
   828   *	command. See the user documentation for details on what it does.
   829   *
   830   * Results:
   831   *	A standard Tcl object result.
   832   *
   833   * Side effects:
   834   *	See the user documentation.
   835   *
   836   *----------------------------------------------------------------------
   837   */
   838  
   839  	/* ARGSUSED */
   840  int
   841  Tcl_ReturnObjCmd(dummy, interp, objc, objv)
   842      ClientData dummy;		/* Not used. */
   843      Tcl_Interp *interp;		/* Current interpreter. */
   844      int objc;			/* Number of arguments. */
   845      Tcl_Obj *CONST objv[];	/* Argument objects. */
   846  {
   847      Interp *iPtr = (Interp *) interp;
   848      int code, level;
   849      Tcl_Obj *valuePtr;
   850  
   851      /* Start with the default options */
   852      if (iPtr->returnOpts != iPtr->defaultReturnOpts) {
   853  	Tcl_DecrRefCount(iPtr->returnOpts);
   854  	iPtr->returnOpts = iPtr->defaultReturnOpts;
   855  	Tcl_IncrRefCount(iPtr->returnOpts);
   856      }
   857  
   858      objv++, objc--;
   859      if (objc) {
   860  	/* We're going to add our options, so manage Tcl_Obj sharing */
   861  	Tcl_DecrRefCount(iPtr->returnOpts);
   862  	iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts);
   863  	Tcl_IncrRefCount(iPtr->returnOpts);
   864      }
   865      
   866      for (;  objc > 1;  objv += 2, objc -= 2) {
   867  	int optLen;
   868  	CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen);
   869  	if ((optLen == 8) && (*opt == '-') && (strcmp(opt, "-options") == 0)) {
   870  	    Tcl_DictSearch search;
   871  	    int done = 0;
   872  	    Tcl_Obj *keyPtr;
   873  	    Tcl_Obj *dict = objv[1];
   874  
   875  	    nestedOptions:
   876  	    if (TCL_ERROR == Tcl_DictObjFirst(NULL, dict,
   877  		    &search, &keyPtr, &valuePtr, &done)) {
   878  		/* Value is not a legal dictionary */
   879  		Tcl_DecrRefCount(iPtr->returnOpts);
   880  		iPtr->returnOpts = iPtr->defaultReturnOpts;
   881  		Tcl_IncrRefCount(iPtr->returnOpts);
   882  		Tcl_ResetResult(interp);
   883  		Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
   884  			"bad -options value: expected dictionary but got \"",
   885  			Tcl_GetString(objv[1]), "\"", (char *) NULL);
   886  		return TCL_ERROR;
   887  	    }
   888  
   889  	    while (!done) {
   890  		Tcl_DictObjPut(NULL, iPtr->returnOpts, keyPtr, valuePtr);
   891  		Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
   892  	    }
   893  
   894  	    valuePtr = NULL;
   895  	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
   896  		    iPtr->returnOptionsKey, &valuePtr);
   897  	    if (valuePtr != NULL) {
   898  		dict = valuePtr;
   899  		Tcl_DictObjRemove(NULL, iPtr->returnOpts,
   900  			iPtr->returnOptionsKey);
   901  		goto nestedOptions;
   902  	    }
   903  
   904  	} else {
   905  	    Tcl_DictObjPut(NULL, iPtr->returnOpts, objv[0], objv[1]);
   906  	}
   907      }
   908  
   909      /* Check for bogus -code value */
   910      Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr);
   911      if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) {
   912  	static CONST char *returnCodes[] = {
   913  	    "ok", "error", "return", "break", "continue", NULL
   914  	};
   915  
   916  	if (TCL_ERROR == Tcl_GetIndexFromObj(NULL, valuePtr, returnCodes,
   917  		NULL, TCL_EXACT, &code)) {
   918  	    /* Value is not a legal return code */
   919  	    Tcl_DecrRefCount(iPtr->returnOpts);
   920  	    iPtr->returnOpts = iPtr->defaultReturnOpts;
   921  	    Tcl_IncrRefCount(iPtr->returnOpts);
   922  	    Tcl_ResetResult(interp);
   923  	    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
   924  		    "bad completion code \"",
   925  		    Tcl_GetString(valuePtr),
   926  		    "\": must be ok, error, return, break, ",
   927  		    "continue, or an integer", (char *) NULL);
   928  	    return TCL_ERROR;
   929  	}
   930  	/* Have a legal string value for a return code; convert to integer */
   931  	Tcl_DictObjPut(NULL, iPtr->returnOpts,
   932  		iPtr->returnCodeKey, Tcl_NewIntObj(code));
   933      }
   934  
   935      /* Check for bogus -level value */
   936      Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr);
   937      if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level) || (level < 0)) {
   938  	/* Value is not a legal level */
   939  	Tcl_DecrRefCount(iPtr->returnOpts);
   940  	iPtr->returnOpts = iPtr->defaultReturnOpts;
   941  	Tcl_IncrRefCount(iPtr->returnOpts);
   942  	Tcl_ResetResult(interp);
   943  	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
   944  		"bad -level value: expected non-negative integer but got \"",
   945  		Tcl_GetString(valuePtr), "\"", (char *) NULL);
   946  	return TCL_ERROR;
   947      }
   948  
   949      /* 
   950       * Convert [return -code return -level X] to
   951       * [return -code ok -level X+1]
   952       */
   953      if (code == TCL_RETURN) {
   954  	level++;
   955  	Tcl_DictObjPut(NULL, iPtr->returnOpts,
   956  		iPtr->returnLevelKey, Tcl_NewIntObj(level));
   957  	Tcl_DictObjPut(NULL, iPtr->returnOpts,
   958  		iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK));
   959      }
   960  
   961      if (level == 0) {
   962  	if (code == TCL_ERROR) {
   963  	    valuePtr = NULL;
   964  	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
   965  		    iPtr->returnErrorinfoKey, &valuePtr);
   966  	    if (valuePtr != NULL) {
   967  		int infoLen;
   968  		CONST char *info = Tcl_GetStringFromObj(valuePtr,&infoLen);
   969  		if (infoLen) {
   970  		    Tcl_AddObjErrorInfo(interp, info, infoLen);
   971  		    iPtr->flags |= ERR_ALREADY_LOGGED;
   972  		}
   973  	    }
   974  	    valuePtr = NULL;
   975  	    Tcl_DictObjGet(NULL, iPtr->returnOpts,
   976  		    iPtr->returnErrorcodeKey, &valuePtr);
   977  	    if (valuePtr != NULL) {
   978  		Tcl_SetVar2Ex(interp, "errorCode", NULL,
   979  			valuePtr, TCL_GLOBAL_ONLY);
   980  		iPtr->flags |= ERROR_CODE_SET;
   981  	    }
   982  	}
   983      } else {
   984  	code = TCL_RETURN;
   985      }
   986  
   987      if (objc == 1) {
   988  	Tcl_SetObjResult(interp, objv[0]);
   989      }
   990      return code;
   991  
   992  }
   993  
   994  /*
   995   *----------------------------------------------------------------------
   996   *
   997   * Tcl_SourceObjCmd --
   998   *
   999   *	This procedure is invoked to process the "source" Tcl command.
  1000   *	See the user documentation for details on what it does.
  1001   *
  1002   * Results:
  1003   *	A standard Tcl object result.
  1004   *
  1005   * Side effects:
  1006   *	See the user documentation.
  1007   *
  1008   *----------------------------------------------------------------------
  1009   */
  1010  
  1011  	/* ARGSUSED */
  1012  int
  1013  Tcl_SourceObjCmd(dummy, interp, objc, objv)
  1014      ClientData dummy;		/* Not used. */
  1015      Tcl_Interp *interp;		/* Current interpreter. */
  1016      int objc;			/* Number of arguments. */
  1017      Tcl_Obj *CONST objv[];	/* Argument objects. */
  1018  {
  1019      CONST char *encodingName = NULL;
  1020      Tcl_Obj *fileName;
  1021  
  1022      if (objc != 2 && objc !=4) {
  1023  	Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
  1024  	return TCL_ERROR;
  1025      }
  1026      fileName = objv[objc-1];
  1027      if (objc == 4) {
  1028  	static CONST char *options[] = {
  1029  	    "-encoding", (char *) NULL
  1030  	};
  1031  	int index;
  1032  	if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1],
  1033  		options, "option", TCL_EXACT, &index)) {
  1034  	    return TCL_ERROR;
  1035  	}
  1036  	encodingName = Tcl_GetString(objv[2]);
  1037      }
  1038      return Tcl_FSEvalFileEx(interp, fileName, encodingName);
  1039  }
  1040  
  1041  /*
  1042   *----------------------------------------------------------------------
  1043   *
  1044   * Tcl_SplitObjCmd --
  1045   *
  1046   *	This procedure is invoked to process the "split" Tcl command.
  1047   *	See the user documentation for details on what it does.
  1048   *
  1049   * Results:
  1050   *	A standard Tcl result.
  1051   *
  1052   * Side effects:
  1053   *	See the user documentation.
  1054   *
  1055   *----------------------------------------------------------------------
  1056   */
  1057  
  1058  	/* ARGSUSED */
  1059  int
  1060  Tcl_SplitObjCmd(dummy, interp, objc, objv)
  1061      ClientData dummy;		/* Not used. */
  1062      Tcl_Interp *interp;		/* Current interpreter. */
  1063      int objc;			/* Number of arguments. */
  1064      Tcl_Obj *CONST objv[];	/* Argument objects. */
  1065  {
  1066      Tcl_UniChar ch;
  1067      int len;
  1068      char *splitChars, *string, *end;
  1069      int splitCharLen, stringLen;
  1070      Tcl_Obj *listPtr, *objPtr;
  1071  
  1072      if (objc == 2) {
  1073  	splitChars = " \n\t\r";
  1074  	splitCharLen = 4;
  1075      } else if (objc == 3) {
  1076  	splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
  1077      } else {
  1078  	Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
  1079  	return TCL_ERROR;
  1080      }
  1081  
  1082      string = Tcl_GetStringFromObj(objv[1], &stringLen);
  1083      end = string + stringLen;
  1084      listPtr = Tcl_GetObjResult(interp);
  1085      
  1086      if (stringLen == 0) {
  1087  	/*
  1088  	 * Do nothing.
  1089  	 */
  1090      } else if (splitCharLen == 0) {
  1091  	Tcl_HashTable charReuseTable;
  1092  	Tcl_HashEntry *hPtr;
  1093  	int isNew;
  1094  
  1095  	/*
  1096  	 * Handle the special case of splitting on every character.
  1097  	 *
  1098  	 * Uses a hash table to ensure that each kind of character has
  1099  	 * only one Tcl_Obj instance (multiply-referenced) in the
  1100  	 * final list.  This is a *major* win when splitting on a long
  1101  	 * string (especially in the megabyte range!) - DKF
  1102  	 */
  1103  
  1104  	Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
  1105  	for ( ; string < end; string += len) {
  1106  	    len = TclUtfToUniChar(string, &ch);
  1107  	    /* Assume Tcl_UniChar is an integral type... */
  1108  	    hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew);
  1109  	    if (isNew) {
  1110  		objPtr = Tcl_NewStringObj(string, len);
  1111  		/* Don't need to fiddle with refcount... */
  1112  		Tcl_SetHashValue(hPtr, (ClientData) objPtr);
  1113  	    } else {
  1114  		objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr);
  1115  	    }
  1116  	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
  1117  	}
  1118  	Tcl_DeleteHashTable(&charReuseTable);
  1119      } else if (splitCharLen == 1) {
  1120  	char *p;
  1121  
  1122  	/*
  1123  	 * Handle the special case of splitting on a single character.
  1124  	 * This is only true for the one-char ASCII case, as one unicode
  1125  	 * char is > 1 byte in length.
  1126  	 */
  1127  
  1128  	while (*string && (p = strchr(string, (int) *splitChars)) != NULL) {
  1129  	    objPtr = Tcl_NewStringObj(string, p - string);
  1130  	    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
  1131  	    string = p + 1;
  1132  	}
  1133  	objPtr = Tcl_NewStringObj(string, end - string);
  1134  	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
  1135      } else {
  1136  	char *element, *p, *splitEnd;
  1137  	int splitLen;
  1138  	Tcl_UniChar splitChar;
  1139  	
  1140  	/*
  1141  	 * Normal case: split on any of a given set of characters.
  1142  	 * Discard instances of the split characters.
  1143  	 */
  1144  
  1145  	splitEnd = splitChars + splitCharLen;
  1146  
  1147  	for (element = string; string < end; string += len) {
  1148  	    len = TclUtfToUniChar(string, &ch);
  1149  	    for (p = splitChars; p < splitEnd; p += splitLen) {
  1150  		splitLen = TclUtfToUniChar(p, &splitChar);
  1151  		if (ch == splitChar) {
  1152  		    objPtr = Tcl_NewStringObj(element, string - element);
  1153  		    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
  1154  		    element = string + len;
  1155  		    break;
  1156  		}
  1157  	    }
  1158  	}
  1159  	objPtr = Tcl_NewStringObj(element, string - element);
  1160  	Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
  1161      }
  1162      return TCL_OK;
  1163  }
  1164  
  1165  /*
  1166   *----------------------------------------------------------------------
  1167   *
  1168   * Tcl_StringObjCmd --
  1169   *
  1170   *	This procedure is invoked to process the "string" Tcl command.
  1171   *	See the user documentation for details on what it does.  Note
  1172   *	that this command only functions correctly on properly formed
  1173   *	Tcl UTF strings.
  1174   *
  1175   *	Note that the primary methods here (equal, compare, match, ...)
  1176   *	have bytecode equivalents.  You will find the code for those in
  1177   *	tclExecute.c.  The code here will only be used in the non-bc
  1178   *	case (like in an 'eval').
  1179   *
  1180   * Results:
  1181   *	A standard Tcl result.
  1182   *
  1183   * Side effects:
  1184   *	See the user documentation.
  1185   *
  1186   *----------------------------------------------------------------------
  1187   */
  1188  
  1189  	/* ARGSUSED */
  1190  int
  1191  Tcl_StringObjCmd(dummy, interp, objc, objv)
  1192      ClientData dummy;		/* Not used. */
  1193      Tcl_Interp *interp;		/* Current interpreter. */
  1194      int objc;			/* Number of arguments. */
  1195      Tcl_Obj *CONST objv[];	/* Argument objects. */
  1196  {
  1197      int index, left, right;
  1198      Tcl_Obj *resultPtr;
  1199      char *string1, *string2;
  1200      int length1, length2;
  1201      static CONST char *options[] = {
  1202  	"bytelength",	"compare",	"equal",	"first",
  1203  	"index",	"is",		"last",		"length",
  1204  	"map",		"match",	"range",	"repeat",
  1205  	"replace",	"tolower",	"toupper",	"totitle",
  1206  	"trim",		"trimleft",	"trimright",
  1207  	"wordend",	"wordstart",	(char *) NULL
  1208      };
  1209      enum options {
  1210  	STR_BYTELENGTH,	STR_COMPARE,	STR_EQUAL,	STR_FIRST,
  1211  	STR_INDEX,	STR_IS,		STR_LAST,	STR_LENGTH,
  1212  	STR_MAP,	STR_MATCH,	STR_RANGE,	STR_REPEAT,
  1213  	STR_REPLACE,	STR_TOLOWER,	STR_TOUPPER,	STR_TOTITLE,
  1214  	STR_TRIM,	STR_TRIMLEFT,	STR_TRIMRIGHT,
  1215  	STR_WORDEND,	STR_WORDSTART
  1216      };	  
  1217  
  1218      if (objc < 2) {
  1219          Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
  1220  	return TCL_ERROR;
  1221      }
  1222      
  1223      if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
  1224  	    &index) != TCL_OK) {
  1225  	return TCL_ERROR;
  1226      }
  1227  
  1228      resultPtr = Tcl_GetObjResult(interp);
  1229      switch ((enum options) index) {
  1230  	case STR_EQUAL:
  1231  	case STR_COMPARE: {
  1232  	    /*
  1233  	     * Remember to keep code here in some sync with the
  1234  	     * byte-compiled versions in tclExecute.c (INST_STR_EQ,
  1235  	     * INST_STR_NEQ and INST_STR_CMP as well as the expr string
  1236  	     * comparison in INST_EQ/INST_NEQ/INST_LT/...).
  1237  	     */
  1238  	    int i, match, length, nocase = 0, reqlength = -1;
  1239  	    int (*strCmpFn)();
  1240  
  1241  	    if (objc < 4 || objc > 7) {
  1242  	    str_cmp_args:
  1243  	        Tcl_WrongNumArgs(interp, 2, objv,
  1244  				 "?-nocase? ?-length int? string1 string2");
  1245  		return TCL_ERROR;
  1246  	    }
  1247  
  1248  	    for (i = 2; i < objc-2; i++) {
  1249  		string2 = Tcl_GetStringFromObj(objv[i], &length2);
  1250  		if ((length2 > 1)
  1251  			&& strncmp(string2, "-nocase", (size_t)length2) == 0) {
  1252  		    nocase = 1;
  1253  		} else if ((length2 > 1)
  1254  			&& strncmp(string2, "-length", (size_t)length2) == 0) {
  1255  		    if (i+1 >= objc-2) {
  1256  			goto str_cmp_args;
  1257  		    }
  1258  		    if (Tcl_GetIntFromObj(interp, objv[++i],
  1259  			    &reqlength) != TCL_OK) {
  1260  			return TCL_ERROR;
  1261  		    }
  1262  		} else {
  1263  		    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
  1264  			    string2, "\": must be -nocase or -length",
  1265  			    (char *) NULL);
  1266  		    return TCL_ERROR;
  1267  		}
  1268  	    }
  1269  
  1270  	    /*
  1271  	     * From now on, we only access the two objects at the end
  1272  	     * of the argument array.
  1273  	     */
  1274  	    objv += objc-2;
  1275  
  1276  	    if ((reqlength == 0) || (objv[0] == objv[1])) {
  1277  		/*
  1278  		 * Alway match at 0 chars of if it is the same obj.
  1279  		 */
  1280  
  1281  		Tcl_SetBooleanObj(resultPtr,
  1282  			((enum options) index == STR_EQUAL));
  1283  		break;
  1284  	    } else if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
  1285  		    objv[1]->typePtr == &tclByteArrayType) {
  1286  		/*
  1287  		 * Use binary versions of comparisons since that won't
  1288  		 * cause undue type conversions and it is much faster.
  1289  		 * Only do this if we're case-sensitive (which is all
  1290  		 * that really makes sense with byte arrays anyway, and
  1291  		 * we have no memcasecmp() for some reason... :^)
  1292  		 */
  1293  		string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1);
  1294  		string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2);
  1295  		strCmpFn = memcmp;
  1296  	    } else if ((objv[0]->typePtr == &tclStringType)
  1297  		    && (objv[1]->typePtr == &tclStringType)) {
  1298  		/*
  1299  		 * Do a unicode-specific comparison if both of the args
  1300  		 * are of String type.  In benchmark testing this proved
  1301  		 * the most efficient check between the unicode and
  1302  		 * string comparison operations.
  1303  		 */
  1304  		string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1);
  1305  		string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2);
  1306  		strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
  1307  	    } else {
  1308  		/*
  1309  		 * As a catch-all we will work with UTF-8.  We cannot use
  1310  		 * memcmp() as that is unsafe with any string containing
  1311  		 * NULL (\xC0\x80 in Tcl's utf rep).  We can use the more
  1312  		 * efficient TclpUtfNcmp2 if we are case-sensitive and no
  1313  		 * specific length was requested.
  1314  		 */
  1315  		string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1);
  1316  		string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2);
  1317  		if ((reqlength < 0) && !nocase) {
  1318  		    strCmpFn = TclpUtfNcmp2;
  1319  		} else {
  1320  		    length1 = Tcl_NumUtfChars(string1, length1);
  1321  		    length2 = Tcl_NumUtfChars(string2, length2);
  1322  		    strCmpFn = nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp;
  1323  		}
  1324  	    }
  1325  
  1326  	    if (((enum options) index == STR_EQUAL)
  1327  		    && (reqlength < 0) && (length1 != length2)) {
  1328  		match = 1; /* this will be reversed below */
  1329  	    } else {
  1330  		length = (length1 < length2) ? length1 : length2;
  1331  		if (reqlength > 0 && reqlength < length) {
  1332  		    length = reqlength;
  1333  		} else if (reqlength < 0) {
  1334  		    /*
  1335  		     * The requested length is negative, so we ignore it by
  1336  		     * setting it to length + 1 so we correct the match var.
  1337  		     */
  1338  		    reqlength = length + 1;
  1339  		}
  1340  		match = strCmpFn(string1, string2, (unsigned) length);
  1341  		if ((match == 0) && (reqlength > length)) {
  1342  		    match = length1 - length2;
  1343  		}
  1344  	    }
  1345  
  1346  	    if ((enum options) index == STR_EQUAL) {
  1347  		Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
  1348  	    } else {
  1349  		Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
  1350  					  (match < 0) ? -1 : 0));
  1351  	    }
  1352  	    break;
  1353  	}
  1354  	case STR_FIRST: {
  1355  	    Tcl_UniChar *ustring1, *ustring2;
  1356  	    int match, start;
  1357  
  1358  	    if (objc < 4 || objc > 5) {
  1359  	        Tcl_WrongNumArgs(interp, 2, objv,
  1360  				 "subString string ?startIndex?");
  1361  		return TCL_ERROR;
  1362  	    }
  1363  
  1364  	    /*
  1365  	     * We are searching string2 for the sequence string1.
  1366  	     */
  1367  
  1368  	    match = -1;
  1369  	    start = 0;
  1370  	    length2 = -1;
  1371  
  1372  	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
  1373  	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
  1374  
  1375  	    if (objc == 5) {
  1376  		/*
  1377  		 * If a startIndex is specified, we will need to fast
  1378  		 * forward to that point in the string before we think
  1379  		 * about a match
  1380  		 */
  1381  		if (TclGetIntForIndex(interp, objv[4], length2 - 1,
  1382  			&start) != TCL_OK) {
  1383  		    return TCL_ERROR;
  1384  		}
  1385  		if (start >= length2) {
  1386  		    goto str_first_done;
  1387  		} else if (start > 0) {
  1388  		    ustring2 += start;
  1389  		    length2  -= start;
  1390  		} else if (start < 0) {
  1391  		    /*
  1392  		     * Invalid start index mapped to string start;
  1393  		     * Bug #423581
  1394  		     */
  1395  		    start = 0;
  1396  		}
  1397  	    }
  1398  
  1399  	    if (length1 > 0) {
  1400  		register Tcl_UniChar *p, *end;
  1401  
  1402  		end = ustring2 + length2 - length1 + 1;
  1403  		for (p = ustring2;  p < end;  p++) {
  1404  		    /*
  1405  		     * Scan forward to find the first character.
  1406  		     */
  1407  		    if ((*p == *ustring1) &&
  1408  			    (TclUniCharNcmp(ustring1, p,
  1409  				    (unsigned long) length1) == 0)) {
  1410  			match = p - ustring2;
  1411  			break;
  1412  		    }
  1413  		}
  1414  	    }
  1415  	    /*
  1416  	     * Compute the character index of the matching string by
  1417  	     * counting the number of characters before the match.
  1418  	     */
  1419  	    if ((match != -1) && (objc == 5)) {
  1420  		match += start;
  1421  	    }
  1422  
  1423  	    str_first_done:
  1424  	    Tcl_SetIntObj(resultPtr, match);
  1425  	    break;
  1426  	}
  1427  	case STR_INDEX: {
  1428  	    if (objc != 4) {
  1429  	        Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
  1430  		return TCL_ERROR;
  1431  	    }
  1432  
  1433  	    /*
  1434  	     * If we have a ByteArray object, avoid indexing in the
  1435  	     * Utf string since the byte array contains one byte per
  1436  	     * character.  Otherwise, use the Unicode string rep to
  1437  	     * get the index'th char.
  1438  	     */
  1439  
  1440  	    if (objv[2]->typePtr == &tclByteArrayType) {
  1441  		string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
  1442  
  1443  		if (TclGetIntForIndex(interp, objv[3], length1 - 1,
  1444  			&index) != TCL_OK) {
  1445  		    return TCL_ERROR;
  1446  		}
  1447  		if ((index >= 0) && (index < length1)) {
  1448  		    Tcl_SetByteArrayObj(resultPtr,
  1449  			    (unsigned char *)(&string1[index]), 1);
  1450  		}
  1451  	    } else {
  1452  		/*
  1453  		 * Get Unicode char length to calulate what 'end' means.
  1454  		 */
  1455  		length1 = Tcl_GetCharLength(objv[2]);
  1456  
  1457  		if (TclGetIntForIndex(interp, objv[3], length1 - 1,
  1458  			&index) != TCL_OK) {
  1459  		    return TCL_ERROR;
  1460  		}
  1461  		if ((index >= 0) && (index < length1)) {
  1462  		    char buf[TCL_UTF_MAX];
  1463  		    Tcl_UniChar ch;
  1464  
  1465  		    ch      = Tcl_GetUniChar(objv[2], index);
  1466  		    length1 = Tcl_UniCharToUtf(ch, buf);
  1467  		    Tcl_SetStringObj(resultPtr, buf, length1);
  1468  		}
  1469  	    }
  1470  	    break;
  1471  	}
  1472  	case STR_IS: {
  1473  	    char *end;
  1474  	    Tcl_UniChar ch;
  1475  
  1476              /*
  1477  	     * The UniChar comparison function
  1478  	     */
  1479  
  1480  	    int (*chcomp)_ANSI_ARGS_((int)) = NULL; 
  1481  	    int i, failat = 0, result = 1, strict = 0;
  1482  	    Tcl_Obj *objPtr, *failVarObj = NULL;
  1483  
  1484  	    static CONST char *isOptions[] = {
  1485  		"alnum",	"alpha",	"ascii",	"control",
  1486  		"boolean",	"digit",	"double",	"false",
  1487  		"graph",	"integer",	"lower",	"print",
  1488  		"punct",	"space",	"true",		"upper",
  1489  		"wordchar",	"xdigit",	(char *) NULL
  1490  	    };
  1491  	    enum isOptions {
  1492  		STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
  1493  		STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_FALSE,
  1494  		STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LOWER,	STR_IS_PRINT,
  1495  		STR_IS_PUNCT,	STR_IS_SPACE,	STR_IS_TRUE,	STR_IS_UPPER,
  1496  		STR_IS_WORD,	STR_IS_XDIGIT
  1497  	    };
  1498  
  1499  	    if (objc < 4 || objc > 7) {
  1500  		Tcl_WrongNumArgs(interp, 2, objv,
  1501  				 "class ?-strict? ?-failindex var? str");
  1502  		return TCL_ERROR;
  1503  	    }
  1504  	    if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
  1505  				    &index) != TCL_OK) {
  1506  		return TCL_ERROR;
  1507  	    }
  1508  	    if (objc != 4) {
  1509  		for (i = 3; i < objc-1; i++) {
  1510  		    string2 = Tcl_GetStringFromObj(objv[i], &length2);
  1511  		    if ((length2 > 1) &&
  1512  			strncmp(string2, "-strict", (size_t) length2) == 0) {
  1513  			strict = 1;
  1514  		    } else if ((length2 > 1) &&
  1515  			    strncmp(string2, "-failindex",
  1516  				    (size_t) length2) == 0) {
  1517  			if (i+1 >= objc-1) {
  1518  			    Tcl_WrongNumArgs(interp, 3, objv,
  1519  					     "?-strict? ?-failindex var? str");
  1520  			    return TCL_ERROR;
  1521  			}
  1522  			failVarObj = objv[++i];
  1523  		    } else {
  1524  			Tcl_AppendStringsToObj(resultPtr, "bad option \"",
  1525  				string2, "\": must be -strict or -failindex",
  1526  				(char *) NULL);
  1527  			return TCL_ERROR;
  1528  		    }
  1529  		}
  1530  	    }
  1531  
  1532  	    /*
  1533  	     * We get the objPtr so that we can short-cut for some classes
  1534  	     * by checking the object type (int and double), but we need
  1535  	     * the string otherwise, because we don't want any conversion
  1536  	     * of type occuring (as, for example, Tcl_Get*FromObj would do
  1537  	     */
  1538  	    objPtr = objv[objc-1];
  1539  	    string1 = Tcl_GetStringFromObj(objPtr, &length1);
  1540  	    if (length1 == 0) {
  1541  		if (strict) {
  1542  		    result = 0;
  1543  		}
  1544  		goto str_is_done;
  1545  	    }
  1546  	    end = string1 + length1;
  1547  
  1548  	    /*
  1549  	     * When entering here, result == 1 and failat == 0
  1550  	     */
  1551  	    switch ((enum isOptions) index) {
  1552  		case STR_IS_ALNUM:
  1553  		    chcomp = Tcl_UniCharIsAlnum;
  1554  		    break;
  1555  		case STR_IS_ALPHA:
  1556  		    chcomp = Tcl_UniCharIsAlpha;
  1557  		    break;
  1558  		case STR_IS_ASCII:
  1559  		    for (; string1 < end; string1++, failat++) {
  1560  			/*
  1561  			 * This is a valid check in unicode, because all
  1562  			 * bytes < 0xC0 are single byte chars (but isascii
  1563  			 * limits that def'n to 0x80).
  1564  			 */
  1565  			if (*((unsigned char *)string1) >= 0x80) {
  1566  			    result = 0;
  1567  			    break;
  1568  			}
  1569  		    }
  1570  		    break;
  1571  		case STR_IS_BOOL:
  1572  		case STR_IS_TRUE:
  1573  		case STR_IS_FALSE:
  1574  		    if (objPtr->typePtr == &tclBooleanType) {
  1575  			if ((((enum isOptions) index == STR_IS_TRUE) &&
  1576  			     objPtr->internalRep.longValue == 0) ||
  1577  			    (((enum isOptions) index == STR_IS_FALSE) &&
  1578  			     objPtr->internalRep.longValue != 0)) {
  1579  			    result = 0;
  1580  			}
  1581  		    } else if ((Tcl_GetBoolean(NULL, string1, &i)
  1582  				== TCL_ERROR) ||
  1583  			       (((enum isOptions) index == STR_IS_TRUE) &&
  1584  				i == 0) ||
  1585  			       (((enum isOptions) index == STR_IS_FALSE) &&
  1586  				i != 0)) {
  1587  			result = 0;
  1588  		    }
  1589  		    break;
  1590  		case STR_IS_CONTROL:
  1591  		    chcomp = Tcl_UniCharIsControl;
  1592  		    break;
  1593  		case STR_IS_DIGIT:
  1594  		    chcomp = Tcl_UniCharIsDigit;
  1595  		    break;
  1596  		case STR_IS_DOUBLE: {
  1597  		    char *stop;
  1598  
  1599  		    if ((objPtr->typePtr == &tclDoubleType) ||
  1600  			(objPtr->typePtr == &tclIntType)) {
  1601  			break;
  1602  		    }
  1603  		    /*
  1604  		     * This is adapted from Tcl_GetDouble
  1605  		     *
  1606  		     * The danger in this function is that
  1607  		     * "12345678901234567890" is an acceptable 'double',
  1608  		     * but will later be interp'd as an int by something
  1609  		     * like [expr].  Therefore, we check to see if it looks
  1610  		     * like an int, and if so we do a range check on it.
  1611  		     * If strtoul gets to the end, we know we either
  1612  		     * received an acceptable int, or over/underflow
  1613  		     */
  1614  		    if (TclLooksLikeInt(string1, length1)) {
  1615  			errno = 0;
  1616  #ifdef TCL_WIDE_INT_IS_LONG
  1617  			strtoul(string1, &stop, 0); /* INTL: Tcl source. */
  1618  #else
  1619  			strtoull(string1, &stop, 0); /* INTL: Tcl source. */
  1620  #endif
  1621  			if (stop == end) {
  1622  			    if (errno == ERANGE) {
  1623  				result = 0;
  1624  				failat = -1;
  1625  			    }
  1626  			    break;
  1627  			}
  1628  		    }
  1629  		    errno = 0;
  1630  		    strtod(string1, &stop); /* INTL: Tcl source. */
  1631  		    if (errno == ERANGE) {
  1632  			/*
  1633  			 * if (errno == ERANGE), then it was an over/underflow
  1634  			 * problem, but in this method, we only want to know
  1635  			 * yes or no, so bad flow returns 0 (false) and sets
  1636  			 * the failVarObj to the string length.
  1637  			 */
  1638  			result = 0;
  1639  			failat = -1;
  1640  		    } else if (stop == string1) {
  1641  			/*
  1642  			 * In this case, nothing like a number was found
  1643  			 */
  1644  			result = 0;
  1645  			failat = 0;
  1646  		    } else {
  1647  			/*
  1648  			 * Assume we sucked up one char per byte
  1649  			 * and then we go onto SPACE, since we are
  1650  			 * allowed trailing whitespace
  1651  			 */
  1652  			failat = stop - string1;
  1653  			string1 = stop;
  1654  			chcomp = Tcl_UniCharIsSpace;
  1655  		    }
  1656  		    break;
  1657  		}
  1658  		case STR_IS_GRAPH:
  1659  		    chcomp = Tcl_UniCharIsGraph;
  1660  		    break;
  1661  		case STR_IS_INT: {
  1662  		    char *stop;
  1663  		    long int l = 0;
  1664  
  1665  		    if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
  1666  			break;
  1667  		    }
  1668  		    /*
  1669  		     * Like STR_IS_DOUBLE, but we use strtoul.
  1670  		     * Since Tcl_GetIntFromObj already failed,
  1671  		     * we set result to 0.
  1672  		     */
  1673  		    result = 0;
  1674  		    errno = 0;
  1675  		    l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
  1676  		    if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
  1677  			/*
  1678  			 * if (errno == ERANGE), then it was an over/underflow
  1679  			 * problem, but in this method, we only want to know
  1680  			 * yes or no, so bad flow returns 0 (false) and sets
  1681  			 * the failVarObj to the string length.
  1682  			 */
  1683  			failat = -1;
  1684  
  1685  		    } else if (stop == string1) {
  1686  			/*
  1687  			 * In this case, nothing like a number was found
  1688  			 */
  1689  			failat = 0;
  1690  		    } else {
  1691  			/*
  1692  			 * Assume we sucked up one char per byte
  1693  			 * and then we go onto SPACE, since we are
  1694  			 * allowed trailing whitespace
  1695  			 */
  1696  			failat = stop - string1;
  1697  			string1 = stop;
  1698  			chcomp = Tcl_UniCharIsSpace;
  1699  		    }
  1700  		    break;
  1701  		}
  1702  		case STR_IS_LOWER:
  1703  		    chcomp = Tcl_UniCharIsLower;
  1704  		    break;
  1705  		case STR_IS_PRINT:
  1706  		    chcomp = Tcl_UniCharIsPrint;
  1707  		    break;
  1708  		case STR_IS_PUNCT:
  1709  		    chcomp = Tcl_UniCharIsPunct;
  1710  		    break;
  1711  		case STR_IS_SPACE:
  1712  		    chcomp = Tcl_UniCharIsSpace;
  1713  		    break;
  1714  		case STR_IS_UPPER:
  1715  		    chcomp = Tcl_UniCharIsUpper;
  1716  		    break;
  1717  		case STR_IS_WORD:
  1718  		    chcomp = Tcl_UniCharIsWordChar;
  1719  		    break;
  1720  		case STR_IS_XDIGIT: {
  1721  		    for (; string1 < end; string1++, failat++) {
  1722  			/* INTL: We assume unicode is bad for this class */
  1723  			if ((*((unsigned char *)string1) >= 0xC0) ||
  1724  			    !isxdigit(*(unsigned char *)string1)) {
  1725  			    result = 0;
  1726  			    break;
  1727  			}
  1728  		    }
  1729  		    break;
  1730  		}
  1731  	    }
  1732  	    if (chcomp != NULL) {
  1733  		for (; string1 < end; string1 += length2, failat++) {
  1734  		    length2 = TclUtfToUniChar(string1, &ch);
  1735  		    if (!chcomp(ch)) {
  1736  			result = 0;
  1737  			break;
  1738  		    }
  1739  		}
  1740  	    }
  1741  	str_is_done:
  1742  	    /*
  1743  	     * Only set the failVarObj when we will return 0
  1744  	     * and we have indicated a valid fail index (>= 0)
  1745  	     */
  1746  	    if ((result == 0) && (failVarObj != NULL) &&
  1747  		Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
  1748  			       TCL_LEAVE_ERR_MSG) == NULL) {
  1749  		return TCL_ERROR;
  1750  	    }
  1751  	    Tcl_SetBooleanObj(resultPtr, result);
  1752  	    break;
  1753  	}
  1754  	case STR_LAST: {
  1755  	    Tcl_UniChar *ustring1, *ustring2, *p;
  1756  	    int match, start;
  1757  
  1758  	    if (objc < 4 || objc > 5) {
  1759  	        Tcl_WrongNumArgs(interp, 2, objv,
  1760  				 "subString string ?startIndex?");
  1761  		return TCL_ERROR;
  1762  	    }
  1763  
  1764  	    /*
  1765  	     * We are searching string2 for the sequence string1.
  1766  	     */
  1767  
  1768  	    match = -1;
  1769  	    start = 0;
  1770  	    length2 = -1;
  1771  
  1772  	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
  1773  	    ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
  1774  
  1775  	    if (objc == 5) {
  1776  		/*
  1777  		 * If a startIndex is specified, we will need to restrict
  1778  		 * the string range to that char index in the string
  1779  		 */
  1780  		if (TclGetIntForIndex(interp, objv[4], length2 - 1,
  1781  			&start) != TCL_OK) {
  1782  		    return TCL_ERROR;
  1783  		}
  1784  		if (start < 0) {
  1785  		    goto str_last_done;
  1786  		} else if (start < length2) {
  1787  		    p = ustring2 + start + 1 - length1;
  1788  		} else {
  1789  		    p = ustring2 + length2 - length1;
  1790  		}
  1791  	    } else {
  1792  		p = ustring2 + length2 - length1;
  1793  	    }
  1794  
  1795  	    if (length1 > 0) {
  1796  		for (; p >= ustring2;  p--) {
  1797  		    /*
  1798  		     * Scan backwards to find the first character.
  1799  		     */
  1800  		    if ((*p == *ustring1) &&
  1801  			    (memcmp((char *) ustring1, (char *) p, (size_t)
  1802  				    (length1 * sizeof(Tcl_UniChar))) == 0)) {
  1803  			match = p - ustring2;
  1804  			break;
  1805  		    }
  1806  		}
  1807  	    }
  1808  
  1809  	    str_last_done:
  1810  	    Tcl_SetIntObj(resultPtr, match);
  1811  	    break;
  1812  	}
  1813  	case STR_BYTELENGTH:
  1814  	case STR_LENGTH: {
  1815  	    if (objc != 3) {
  1816  	        Tcl_WrongNumArgs(interp, 2, objv, "string");
  1817  		return TCL_ERROR;
  1818  	    }
  1819  
  1820  	    if ((enum options) index == STR_BYTELENGTH) {
  1821  		(void) Tcl_GetStringFromObj(objv[2], &length1);
  1822  	    } else {
  1823  		/*
  1824  		 * If we have a ByteArray object, avoid recomputing the
  1825  		 * string since the byte array contains one byte per
  1826  		 * character.  Otherwise, use the Unicode string rep to
  1827  		 * calculate the length.
  1828  		 */
  1829  
  1830  		if (objv[2]->typePtr == &tclByteArrayType) {
  1831  		    (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
  1832  		} else {
  1833  		    length1 = Tcl_GetCharLength(objv[2]);
  1834  		}
  1835  	    }
  1836  	    Tcl_SetIntObj(resultPtr, length1);
  1837  	    break;
  1838  	}
  1839  	case STR_MAP: {
  1840  	    int mapElemc, nocase = 0, mapWithDict = 0;
  1841  	    Tcl_Obj **mapElemv;
  1842  	    Tcl_UniChar *ustring1, *ustring2, *p, *end;
  1843  	    int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
  1844  		    CONST Tcl_UniChar*, unsigned long));
  1845  
  1846  	    if (objc < 4 || objc > 5) {
  1847  	        Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
  1848  		return TCL_ERROR;
  1849  	    }
  1850  
  1851  	    if (objc == 5) {
  1852  		string2 = Tcl_GetStringFromObj(objv[2], &length2);
  1853  		if ((length2 > 1) &&
  1854  		    strncmp(string2, "-nocase", (size_t) length2) == 0) {
  1855  		    nocase = 1;
  1856  		} else {
  1857  		    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
  1858  			    string2, "\": must be -nocase", (char *) NULL);
  1859  		    return TCL_ERROR;
  1860  		}
  1861  	    }
  1862  
  1863  	    /*
  1864  	     * This test is tricky, but has to be that way or you get
  1865  	     * other strange inconsistencies (see test string-10.20
  1866  	     * for illustration why!)
  1867  	     */
  1868  	    if (objv[objc-2]->typePtr == &tclDictType &&
  1869  		    objv[objc-2]->bytes == NULL) {
  1870  		int i, done;
  1871  		Tcl_DictSearch search;
  1872  
  1873  		/*
  1874  		 * We know the type exactly, so all dict operations
  1875  		 * will succeed for sure.  This shortens this code
  1876  		 * quite a bit.
  1877  		 */
  1878  		Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
  1879  		if (mapElemc == 0) {
  1880  		    /*
  1881  		     * empty charMap, just return whatever string was given
  1882  		     */
  1883  		    Tcl_SetObjResult(interp, objv[objc-1]);
  1884  		    return TCL_OK;
  1885  		}
  1886  		mapElemc *= 2;
  1887  		mapWithDict = 1;
  1888  		/*
  1889  		 * Copy the dictionary out into an array; that's the
  1890  		 * easiest way to adapt this code...
  1891  		 */
  1892  		mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc);
  1893  		Tcl_DictObjFirst(interp, objv[objc-2], &search,
  1894  			mapElemv+0, mapElemv+1, &done);
  1895  		for (i=2 ; i<mapElemc ; i+=2) {
  1896  		    Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
  1897  		}
  1898  	    } else {
  1899  		if (Tcl_ListObjGetElements(interp, objv[objc-2],
  1900  			&mapElemc, &mapElemv) != TCL_OK) {
  1901  		    return TCL_ERROR;
  1902  		}
  1903  		if (mapElemc == 0) {
  1904  		    /*
  1905  		     * empty charMap, just return whatever string was given
  1906  		     */
  1907  		    Tcl_SetObjResult(interp, objv[objc-1]);
  1908  		    return TCL_OK;
  1909  		} else if (mapElemc & 1) {
  1910  		    /*
  1911  		     * The charMap must be an even number of key/value items
  1912  		     */
  1913  		    Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
  1914  		    return TCL_ERROR;
  1915  		}
  1916  	    }
  1917  	    objc--;
  1918  
  1919  	    ustring1 = Tcl_GetUnicodeFromObj(objv[objc], &length1);
  1920  	    if (length1 == 0) {
  1921  		/*
  1922  		 * Empty input string, just stop now
  1923  		 */
  1924  		if (mapWithDict) {
  1925  		    ckfree((char *) mapElemv);
  1926  		}
  1927  		break;
  1928  	    }
  1929  	    end = ustring1 + length1;
  1930  
  1931  	    strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
  1932  
  1933  	    /*
  1934  	     * Force result to be Unicode
  1935  	     */
  1936  	    Tcl_SetUnicodeObj(resultPtr, ustring1, 0);
  1937  
  1938  	    if (mapElemc == 2) {
  1939  		/*
  1940  		 * Special case for one map pair which avoids the extra
  1941  		 * for loop and extra calls to get Unicode data.  The
  1942  		 * algorithm is otherwise identical to the multi-pair case.
  1943  		 * This will be >30% faster on larger strings.
  1944  		 */
  1945  		int mapLen;
  1946  		Tcl_UniChar *mapString, u2lc;
  1947  
  1948  		ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
  1949  		p = ustring1;
  1950  		if (length2 == 0) {
  1951  		    ustring1 = end;
  1952  		} else {
  1953  		    mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
  1954  		    u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
  1955  		    for (; ustring1 < end; ustring1++) {
  1956  			if (((*ustring1 == *ustring2) ||
  1957  				(nocase && (Tcl_UniCharToLower(*ustring1) ==
  1958  					u2lc))) &&
  1959  				((length2 == 1) || strCmpFn(ustring1, ustring2,
  1960  					(unsigned long) length2) == 0)) {
  1961  			    if (p != ustring1) {
  1962  				Tcl_AppendUnicodeToObj(resultPtr, p,
  1963  					ustring1 - p);
  1964  				p = ustring1 + length2;
  1965  			    } else {
  1966  				p += length2;
  1967  			    }
  1968  			    ustring1 = p - 1;
  1969  
  1970  			    Tcl_AppendUnicodeToObj(resultPtr, mapString,
  1971  				    mapLen);
  1972  			}
  1973  		    }
  1974  		}
  1975  	    } else {
  1976  		Tcl_UniChar **mapStrings, *u2lc = NULL;
  1977  		int *mapLens;
  1978  		/*
  1979  		 * Precompute pointers to the unicode string and length.
  1980  		 * This saves us repeated function calls later,
  1981  		 * significantly speeding up the algorithm.  We only need
  1982  		 * the lowercase first char in the nocase case.
  1983  		 */
  1984  		mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2)
  1985  			* sizeof(Tcl_UniChar *));
  1986  		mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int));
  1987  		if (nocase) {
  1988  		    u2lc = (Tcl_UniChar *)
  1989  			    ckalloc((mapElemc) * sizeof(Tcl_UniChar));
  1990  		}
  1991  		for (index = 0; index < mapElemc; index++) {
  1992  		    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
  1993  			    &(mapLens[index]));
  1994  		    if (nocase && ((index % 2) == 0)) {
  1995  			u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
  1996  		    }
  1997  		}
  1998  		for (p = ustring1; ustring1 < end; ustring1++) {
  1999  		    for (index = 0; index < mapElemc; index += 2) {
  2000  			/*
  2001  			 * Get the key string to match on.
  2002  			 */
  2003  			ustring2 = mapStrings[index];
  2004  			length2  = mapLens[index];
  2005  			if ((length2 > 0) && ((*ustring1 == *ustring2) ||
  2006  				(nocase && (Tcl_UniCharToLower(*ustring1) ==
  2007  					u2lc[index/2]))) &&
  2008  				((length2 == 1) || strCmpFn(ustring2, ustring1,
  2009  					(unsigned long) length2) == 0)) {
  2010  			    if (p != ustring1) {
  2011  				/*
  2012  				 * Put the skipped chars onto the result first
  2013  				 */
  2014  				Tcl_AppendUnicodeToObj(resultPtr, p,
  2015  					ustring1 - p);
  2016  				p = ustring1 + length2;
  2017  			    } else {
  2018  				p += length2;
  2019  			    }
  2020  			    /*
  2021  			     * Adjust len to be full length of matched string
  2022  			     */
  2023  			    ustring1 = p - 1;
  2024  
  2025  			    /*
  2026  			     * Append the map value to the unicode string
  2027  			     */
  2028  			    Tcl_AppendUnicodeToObj(resultPtr,
  2029  				    mapStrings[index+1], mapLens[index+1]);
  2030  			    break;
  2031  			}
  2032  		    }
  2033  		}
  2034  		ckfree((char *) mapStrings);
  2035  		ckfree((char *) mapLens);
  2036  		if (nocase) {
  2037  		    ckfree((char *) u2lc);
  2038  		}
  2039  	    }
  2040  	    if (p != ustring1) {
  2041  		/*
  2042  		 * Put the rest of the unmapped chars onto result
  2043  		 */
  2044  		Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
  2045  	    }
  2046  	    if (mapWithDict) {
  2047  		ckfree((char *) mapElemv);
  2048  	    }
  2049  	    break;
  2050  	}
  2051  	case STR_MATCH: {
  2052  	    Tcl_UniChar *ustring1, *ustring2;
  2053  	    int nocase = 0;
  2054  
  2055  	    if (objc < 4 || objc > 5) {
  2056  	        Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
  2057  		return TCL_ERROR;
  2058  	    }
  2059  
  2060  	    if (objc == 5) {
  2061  		string2 = Tcl_GetStringFromObj(objv[2], &length2);
  2062  		if ((length2 > 1) &&
  2063  		    strncmp(string2, "-nocase", (size_t) length2) == 0) {
  2064  		    nocase = 1;
  2065  		} else {
  2066  		    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
  2067  					   string2, "\": must be -nocase",
  2068  					   (char *) NULL);
  2069  		    return TCL_ERROR;
  2070  		}
  2071  	    }
  2072  	    ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1);
  2073  	    ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2);
  2074  	    Tcl_SetBooleanObj(resultPtr, TclUniCharMatch(ustring1, length1,
  2075  		    ustring2, length2, nocase));
  2076  	    break;
  2077  	}
  2078  	case STR_RANGE: {
  2079  	    int first, last;
  2080  
  2081  	    if (objc != 5) {
  2082  	        Tcl_WrongNumArgs(interp, 2, objv, "string first last");
  2083  		return TCL_ERROR;
  2084  	    }
  2085  
  2086  	    /*
  2087  	     * If we have a ByteArray object, avoid indexing in the
  2088  	     * Utf string since the byte array contains one byte per
  2089  	     * character.  Otherwise, use the Unicode string rep to
  2090  	     * get the range.
  2091  	     */
  2092  
  2093  	    if (objv[2]->typePtr == &tclByteArrayType) {
  2094  		string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
  2095  		length1--;
  2096  	    } else {
  2097  		/*
  2098  		 * Get the length in actual characters.
  2099  		 */
  2100  		string1 = NULL;
  2101  		length1 = Tcl_GetCharLength(objv[2]) - 1;
  2102  	    }
  2103  
  2104  	    if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
  2105  		    || (TclGetIntForIndex(interp, objv[4], length1,
  2106  			    &last) != TCL_OK)) {
  2107  		return TCL_ERROR;
  2108  	    }
  2109  
  2110  	    if (first < 0) {
  2111  		first = 0;
  2112  	    }
  2113  	    if (last >= length1) {
  2114  		last = length1;
  2115  	    }
  2116  	    if (last >= first) {
  2117  		if (string1 != NULL) {
  2118  		    int numBytes = last - first + 1;
  2119  		    resultPtr = Tcl_NewByteArrayObj(
  2120  			(unsigned char *) &string1[first], numBytes);
  2121  		    Tcl_SetObjResult(interp, resultPtr);
  2122  		} else {
  2123  		    Tcl_SetObjResult(interp,
  2124  			    Tcl_GetRange(objv[2], first, last));
  2125  		}
  2126  	    }
  2127  	    break;
  2128  	}
  2129  	case STR_REPEAT: {
  2130  	    int count;
  2131  
  2132  	    if (objc != 4) {
  2133  		Tcl_WrongNumArgs(interp, 2, objv, "string count");
  2134  		return TCL_ERROR;
  2135  	    }
  2136  
  2137  	    if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
  2138  		return TCL_ERROR;
  2139  	    }
  2140  
  2141  	    if (count == 1) {
  2142  		Tcl_SetObjResult(interp, objv[2]);
  2143  	    } else if (count > 1) {
  2144  		string1 = Tcl_GetStringFromObj(objv[2], &length1);
  2145  		if (length1 > 0) {
  2146  		    /*
  2147  		     * Only build up a string that has data.  Instead of
  2148  		     * building it up with repeated appends, we just allocate
  2149  		     * the necessary space once and copy the string value in.
  2150  		     * Check for overflow with back-division. [Bug #714106]
  2151  		     */
  2152  		    length2		= length1 * count;
  2153  		    if ((length2 / count) != length1) {
  2154  			char buf[TCL_INTEGER_SPACE+1];
  2155  			sprintf(buf, "%d", INT_MAX);
  2156  			Tcl_AppendStringsToObj(resultPtr,
  2157  				"string size overflow, must be less than ",
  2158  				buf, (char *) NULL);
  2159  			return TCL_ERROR;
  2160  		    }
  2161  		    /*
  2162  		     * Include space for the NULL
  2163  		     */
  2164  		    string2		= (char *) ckalloc((size_t) length2+1);
  2165  		    for (index = 0; index < count; index++) {
  2166  			memcpy(string2 + (length1 * index), string1,
  2167  				(size_t) length1);
  2168  		    }
  2169  		    string2[length2]	= '\0';
  2170  		    /*
  2171  		     * We have to directly assign this instead of using
  2172  		     * Tcl_SetStringObj (and indirectly TclInitStringRep)
  2173  		     * because that makes another copy of the data.
  2174  		     */
  2175  		    resultPtr		= Tcl_NewObj();
  2176  		    resultPtr->bytes	= string2;
  2177  		    resultPtr->length	= length2;
  2178  		    Tcl_SetObjResult(interp, resultPtr);
  2179  		}
  2180  	    }
  2181  	    break;
  2182  	}
  2183  	case STR_REPLACE: {
  2184  	    Tcl_UniChar *ustring1;
  2185  	    int first, last;
  2186  
  2187  	    if (objc < 5 || objc > 6) {
  2188  	        Tcl_WrongNumArgs(interp, 2, objv,
  2189  				 "string first last ?string?");
  2190  		return TCL_ERROR;
  2191  	    }
  2192  
  2193  	    ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
  2194  	    length1--;
  2195  
  2196  	    if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
  2197  		    || (TclGetIntForIndex(interp, objv[4], length1,
  2198  			    &last) != TCL_OK)) {
  2199  		return TCL_ERROR;
  2200  	    }
  2201  
  2202  	    if ((last < first) || (last < 0) || (first > length1)) {
  2203  		Tcl_SetObjResult(interp, objv[2]);
  2204  	    } else {
  2205  		if (first < 0) {
  2206  		    first = 0;
  2207  		}
  2208  
  2209  		Tcl_SetUnicodeObj(resultPtr, ustring1, first);
  2210  		if (objc == 6) {
  2211  		    Tcl_AppendObjToObj(resultPtr, objv[5]);
  2212  		}
  2213  		if (last < length1) {
  2214  		    Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
  2215  			    length1 - last);
  2216  		}
  2217  	    }
  2218  	    break;
  2219  	}
  2220  	case STR_TOLOWER:
  2221  	case STR_TOUPPER:
  2222  	case STR_TOTITLE:
  2223  	    if (objc < 3 || objc > 5) {
  2224  	        Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
  2225  		return TCL_ERROR;
  2226  	    }
  2227  
  2228  	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
  2229  
  2230  	    if (objc == 3) {
  2231  		/*
  2232  		 * Since the result object is not a shared object, it is
  2233  		 * safe to copy the string into the result and do the
  2234  		 * conversion in place.  The conversion may change the length
  2235  		 * of the string, so reset the length after conversion.
  2236  		 */
  2237  
  2238  		Tcl_SetStringObj(resultPtr, string1, length1);
  2239  		if ((enum options) index == STR_TOLOWER) {
  2240  		    length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
  2241  		} else if ((enum options) index == STR_TOUPPER) {
  2242  		    length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
  2243  		} else {
  2244  		    length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
  2245  		}
  2246  		Tcl_SetObjLength(resultPtr, length1);
  2247  	    } else {
  2248  		int first, last;
  2249  		CONST char *start, *end;
  2250  
  2251  		length1 = Tcl_NumUtfChars(string1, length1) - 1;
  2252  		if (TclGetIntForIndex(interp, objv[3], length1,
  2253  				      &first) != TCL_OK) {
  2254  		    return TCL_ERROR;
  2255  		}
  2256  		if (first < 0) {
  2257  		    first = 0;
  2258  		}
  2259  		last = first;
  2260  		if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
  2261  						      &last) != TCL_OK)) {
  2262  		    return TCL_ERROR;
  2263  		}
  2264  		if (last >= length1) {
  2265  		    last = length1;
  2266  		}
  2267  		if (last < first) {
  2268  		    Tcl_SetObjResult(interp, objv[2]);
  2269  		    break;
  2270  		}
  2271  		start = Tcl_UtfAtIndex(string1, first);
  2272  		end = Tcl_UtfAtIndex(start, last - first + 1);
  2273  		length2 = end-start;
  2274  		string2 = ckalloc((size_t) length2+1);
  2275  		memcpy(string2, start, (size_t) length2);
  2276  		string2[length2] = '\0';
  2277  		if ((enum options) index == STR_TOLOWER) {
  2278  		    length2 = Tcl_UtfToLower(string2);
  2279  		} else if ((enum options) index == STR_TOUPPER) {
  2280  		    length2 = Tcl_UtfToUpper(string2);
  2281  		} else {
  2282  		    length2 = Tcl_UtfToTitle(string2);
  2283  		}
  2284  		Tcl_SetStringObj(resultPtr, string1, start - string1);
  2285  		Tcl_AppendToObj(resultPtr, string2, length2);
  2286  		Tcl_AppendToObj(resultPtr, end, -1);
  2287  		ckfree(string2);
  2288  	    }
  2289  	    break;
  2290  
  2291  	case STR_TRIM: {
  2292  	    Tcl_UniChar ch, trim;
  2293  	    register CONST char *p, *end;
  2294  	    char *check, *checkEnd;
  2295  	    int offset;
  2296  
  2297  	    left = 1;
  2298  	    right = 1;
  2299  
  2300  	    dotrim:
  2301  	    if (objc == 4) {
  2302  		string2 = Tcl_GetStringFromObj(objv[3], &length2);
  2303  	    } else if (objc == 3) {
  2304  		string2 = " \t\n\r";
  2305  		length2 = strlen(string2);
  2306  	    } else {
  2307  	        Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
  2308  		return TCL_ERROR;
  2309  	    }
  2310  	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
  2311  	    checkEnd = string2 + length2;
  2312  
  2313  	    if (left) {
  2314  		end = string1 + length1;
  2315  		/*
  2316  		 * The outer loop iterates over the string.  The inner
  2317  		 * loop iterates over the trim characters.  The loops
  2318  		 * terminate as soon as a non-trim character is discovered
  2319  		 * and string1 is left pointing at the first non-trim
  2320  		 * character.
  2321  		 */
  2322  
  2323  		for (p = string1; p < end; p += offset) {
  2324  		    offset = TclUtfToUniChar(p, &ch);
  2325  		    
  2326  		    for (check = string2; ; ) {
  2327  			if (check >= checkEnd) {
  2328  			    p = end;
  2329  			    break;
  2330  			}
  2331  			check += TclUtfToUniChar(check, &trim);
  2332  			if (ch == trim) {
  2333  			    length1 -= offset;
  2334  			    string1 += offset;
  2335  			    break;
  2336  			}
  2337  		    }
  2338  		}
  2339  	    }
  2340  	    if (right) {
  2341  	        end = string1;
  2342  
  2343  		/*
  2344  		 * The outer loop iterates over the string.  The inner
  2345  		 * loop iterates over the trim characters.  The loops
  2346  		 * terminate as soon as a non-trim character is discovered
  2347  		 * and length1 marks the last non-trim character.
  2348  		 */
  2349  
  2350  		for (p = string1 + length1; p > end; ) {
  2351  		    p = Tcl_UtfPrev(p, string1);
  2352  		    offset = TclUtfToUniChar(p, &ch);
  2353  		    for (check = string2; ; ) {
  2354  		        if (check >= checkEnd) {
  2355  			    p = end;
  2356  			    break;
  2357  			}
  2358  			check += TclUtfToUniChar(check, &trim);
  2359  			if (ch == trim) {
  2360  			    length1 -= offset;
  2361  			    break;
  2362  			}
  2363  		    }
  2364  		}
  2365  	    }
  2366  	    Tcl_SetStringObj(resultPtr, string1, length1);
  2367  	    break;
  2368  	}
  2369  	case STR_TRIMLEFT: {
  2370  	    left = 1;
  2371  	    right = 0;
  2372  	    goto dotrim;
  2373  	}
  2374  	case STR_TRIMRIGHT: {
  2375  	    left = 0;
  2376  	    right = 1;
  2377  	    goto dotrim;
  2378  	}
  2379  	case STR_WORDEND: {
  2380  	    int cur;
  2381  	    Tcl_UniChar ch;
  2382  	    CONST char *p, *end;
  2383  	    int numChars;
  2384  	    
  2385  	    if (objc != 4) {
  2386  	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
  2387  		return TCL_ERROR;
  2388  	    }
  2389  
  2390  	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
  2391  	    numChars = Tcl_NumUtfChars(string1, length1);
  2392  	    if (TclGetIntForIndex(interp, objv[3], numChars-1,
  2393  				  &index) != TCL_OK) {
  2394  		return TCL_ERROR;
  2395  	    }
  2396  	    if (index < 0) {
  2397  		index = 0;
  2398  	    }
  2399  	    if (index < numChars) {
  2400  		p = Tcl_UtfAtIndex(string1, index);
  2401  		end = string1+length1;
  2402  		for (cur = index; p < end; cur++) {
  2403  		    p += TclUtfToUniChar(p, &ch);
  2404  		    if (!Tcl_UniCharIsWordChar(ch)) {
  2405  			break;
  2406  		    }
  2407  		}
  2408  		if (cur == index) {
  2409  		    cur++;
  2410  		}
  2411  	    } else {
  2412  		cur = numChars;
  2413  	    }
  2414  	    Tcl_SetIntObj(resultPtr, cur);
  2415  	    break;
  2416  	}
  2417  	case STR_WORDSTART: {
  2418  	    int cur;
  2419  	    Tcl_UniChar ch;
  2420  	    CONST char *p;
  2421  	    int numChars;
  2422  	    
  2423  	    if (objc != 4) {
  2424  	        Tcl_WrongNumArgs(interp, 2, objv, "string index");
  2425  		return TCL_ERROR;
  2426  	    }
  2427  
  2428  	    string1 = Tcl_GetStringFromObj(objv[2], &length1);
  2429  	    numChars = Tcl_NumUtfChars(string1, length1);
  2430  	    if (TclGetIntForIndex(interp, objv[3], numChars-1,
  2431  				  &index) != TCL_OK) {
  2432  		return TCL_ERROR;
  2433  	    }
  2434  	    if (index >= numChars) {
  2435  		index = numChars - 1;
  2436  	    }
  2437  	    cur = 0;
  2438  	    if (index > 0) {
  2439  		p = Tcl_UtfAtIndex(string1, index);
  2440  	        for (cur = index; cur >= 0; cur--) {
  2441  		    TclUtfToUniChar(p, &ch);
  2442  		    if (!Tcl_UniCharIsWordChar(ch)) {
  2443  			break;
  2444  		    }
  2445  		    p = Tcl_UtfPrev(p, string1);
  2446  		}
  2447  		if (cur != index) {
  2448  		    cur += 1;
  2449  		}
  2450  	    }
  2451  	    Tcl_SetIntObj(resultPtr, cur);
  2452  	    break;
  2453  	}
  2454      }
  2455      return TCL_OK;
  2456  }
  2457  
  2458  /*
  2459   *----------------------------------------------------------------------
  2460   *
  2461   * Tcl_SubstObjCmd --
  2462   *
  2463   *	This procedure is invoked to process the "subst" Tcl command.
  2464   *	See the user documentation for details on what it does.  This
  2465   *	command relies on Tcl_SubstObj() for its implementation.
  2466   *
  2467   * Results:
  2468   *	A standard Tcl result.
  2469   *
  2470   * Side effects:
  2471   *	See the user documentation.
  2472   *
  2473   *----------------------------------------------------------------------
  2474   */
  2475  
  2476  	/* ARGSUSED */
  2477  int
  2478  Tcl_SubstObjCmd(dummy, interp, objc, objv)
  2479      ClientData dummy;			/* Not used. */
  2480      Tcl_Interp *interp;			/* Current interpreter. */
  2481      int objc;				/* Number of arguments. */
  2482      Tcl_Obj *CONST objv[];       	/* Argument objects. */
  2483  {
  2484      static CONST char *substOptions[] = {
  2485  	"-nobackslashes", "-nocommands", "-novariables", (char *) NULL
  2486      };
  2487      enum substOptions {
  2488  	SUBST_NOBACKSLASHES,      SUBST_NOCOMMANDS,       SUBST_NOVARS
  2489      };
  2490      Tcl_Obj *resultPtr;
  2491      int optionIndex, flags, i;
  2492  
  2493      /*
  2494       * Parse command-line options.
  2495       */
  2496  
  2497      flags = TCL_SUBST_ALL;
  2498      for (i = 1; i < (objc-1); i++) {
  2499  	if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
  2500  		"switch", 0, &optionIndex) != TCL_OK) {
  2501  
  2502  	    return TCL_ERROR;
  2503  	}
  2504  	switch (optionIndex) {
  2505  	    case SUBST_NOBACKSLASHES: {
  2506  		flags &= ~TCL_SUBST_BACKSLASHES;
  2507  		break;
  2508  	    }
  2509  	    case SUBST_NOCOMMANDS: {
  2510  		flags &= ~TCL_SUBST_COMMANDS;
  2511  		break;
  2512  	    }
  2513  	    case SUBST_NOVARS: {
  2514  		flags &= ~TCL_SUBST_VARIABLES;
  2515  		break;
  2516  	    }
  2517  	    default: {
  2518  		panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
  2519  	    }
  2520  	}
  2521      }
  2522      if (i != (objc-1)) {
  2523  	Tcl_WrongNumArgs(interp, 1, objv,
  2524  		"?-nobackslashes? ?-nocommands? ?-novariables? string");
  2525  	return TCL_ERROR;
  2526      }
  2527  
  2528      /*
  2529       * Perform the substitution.
  2530       */
  2531      resultPtr = Tcl_SubstObj(interp, objv[i], flags);
  2532  
  2533      if (resultPtr == NULL) {
  2534  	return TCL_ERROR;
  2535      }
  2536      Tcl_SetObjResult(interp, resultPtr);
  2537      return TCL_OK;
  2538  }
  2539  
  2540  /*
  2541   *----------------------------------------------------------------------
  2542   *
  2543   * Tcl_SwitchObjCmd --
  2544   *
  2545   *	This object-based procedure is invoked to process the "switch" Tcl
  2546   *	command. See the user documentation for details on what it does.
  2547   *
  2548   * Results:
  2549   *	A standard Tcl object result.
  2550   *
  2551   * Side effects:
  2552   *	See the user documentation.
  2553   *
  2554   *----------------------------------------------------------------------
  2555   */
  2556  
  2557  	/* ARGSUSED */
  2558  int
  2559  Tcl_SwitchObjCmd(dummy, interp, objc, objv)
  2560      ClientData dummy;		/* Not used. */
  2561      Tcl_Interp *interp;		/* Current interpreter. */
  2562      int objc;			/* Number of arguments. */
  2563      Tcl_Obj *CONST objv[];	/* Argument objects. */
  2564  {
  2565      int i, j, index, mode, matched, result, splitObjs, numMatchesSaved;
  2566      char *string, *pattern;
  2567      Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
  2568      Tcl_Obj *CONST *savedObjv = objv;
  2569      Tcl_RegExp regExpr;
  2570      static CONST char *options[] = {
  2571  	"-exact", "-glob", "-indexvar", "-matchvar", "-regexp", "--", 
  2572  	NULL
  2573      };
  2574      enum options {
  2575  	OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_REGEXP, OPT_LAST
  2576      };
  2577  
  2578      mode = OPT_EXACT;
  2579      indexVarObj = NULL;
  2580      matchVarObj = NULL;
  2581      numMatchesSaved = 0;
  2582      for (i = 1; i < objc; i++) {
  2583  	string = Tcl_GetString(objv[i]);
  2584  	if (string[0] != '-') {
  2585  	    break;
  2586  	}
  2587  	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 
  2588  		&index) != TCL_OK) {
  2589  	    return TCL_ERROR;
  2590  	}
  2591  	if (index == OPT_LAST) {
  2592  	    i++;
  2593  	    break;
  2594  	}
  2595  
  2596  	/*
  2597  	 * Check for TIP#75 options specifying the variables to write
  2598  	 * regexp information into.
  2599  	 */
  2600  
  2601  	if (index == OPT_INDEXV) {
  2602  	    i++;
  2603  	    if (i == objc) {
  2604  		Tcl_AppendResult(interp,
  2605  			"missing variable name argument to -indexvar option",
  2606  			(char *) NULL);
  2607  		return TCL_ERROR;
  2608  	    }
  2609  	    indexVarObj = objv[i];
  2610  	    numMatchesSaved = -1;
  2611  	} else if (index == OPT_MATCHV) {
  2612  	    i++;
  2613  	    if (i == objc) {
  2614  		Tcl_AppendResult(interp,
  2615  			"missing variable name argument to -matchvar option",
  2616  			(char *) NULL);
  2617  		return TCL_ERROR;
  2618  	    }
  2619  	    matchVarObj = objv[i];
  2620  	    numMatchesSaved = -1;
  2621  	} else {
  2622  	    mode = index;
  2623  	}
  2624      }
  2625  
  2626      if (objc - i < 2) {
  2627  	Tcl_WrongNumArgs(interp, 1, objv,
  2628  		"?switches? string pattern body ... ?default body?");
  2629  	return TCL_ERROR;
  2630      }
  2631      if (indexVarObj != NULL && mode != OPT_REGEXP) {
  2632  	Tcl_AppendResult(interp,
  2633  		"-indexvar option requires -regexp option", (char *) NULL);
  2634  	return TCL_ERROR;
  2635      }
  2636      if (matchVarObj != NULL && mode != OPT_REGEXP) {
  2637  	Tcl_AppendResult(interp,
  2638  		"-matchvar option requires -regexp option", (char *) NULL);
  2639  	return TCL_ERROR;
  2640      }
  2641  
  2642      stringObj = objv[i];
  2643      objc -= i + 1;
  2644      objv += i + 1;
  2645  
  2646      /*
  2647       * If all of the pattern/command pairs are lumped into a single
  2648       * argument, split them out again.
  2649       */
  2650  
  2651      splitObjs = 0;
  2652      if (objc == 1) {
  2653  	Tcl_Obj **listv;
  2654  
  2655  	if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
  2656  	    return TCL_ERROR;
  2657  	}
  2658  
  2659  	/*
  2660  	 * Ensure that the list is non-empty.
  2661  	 */
  2662  
  2663  	if (objc < 1) {
  2664  	    Tcl_WrongNumArgs(interp, 1, savedObjv,
  2665  		    "?switches? string {pattern body ... ?default body?}");
  2666  	    return TCL_ERROR;
  2667  	}
  2668  	objv = listv;
  2669  	splitObjs = 1;
  2670      }
  2671  
  2672      /*
  2673       * Complain if there is an odd number of words in the list of
  2674       * patterns and bodies.
  2675       */
  2676  
  2677      if (objc % 2) {
  2678  	Tcl_ResetResult(interp);
  2679  	Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
  2680  
  2681  	/*
  2682  	 * Check if this can be due to a badly placed comment
  2683  	 * in the switch block.
  2684  	 *
  2685  	 * The following is an heuristic to detect the infamous
  2686  	 * "comment in switch" error: just check if a pattern
  2687  	 * begins with '#'.
  2688  	 */
  2689  
  2690  	if (splitObjs) {
  2691  	    for (i=0 ; i<objc ; i+=2) {
  2692  		if (Tcl_GetString(objv[i])[0] == '#') {
  2693  		    Tcl_AppendResult(interp, ", this may be due to a ",
  2694  			    "comment incorrectly placed outside of a ",
  2695  			    "switch body - see the \"switch\" ",
  2696  			    "documentation", NULL);
  2697  		    break;
  2698  		}
  2699  	    }
  2700  	}
  2701  
  2702  	return TCL_ERROR;
  2703      }
  2704  
  2705      /*
  2706       * Complain if the last body is a continuation.  Note that this
  2707       * check assumes that the list is non-empty!
  2708       */
  2709  
  2710      if (strcmp(Tcl_GetString(objv[objc-1]), "-") == 0) {
  2711  	Tcl_ResetResult(interp);
  2712  	Tcl_AppendResult(interp, "no body specified for pattern \"",
  2713  		Tcl_GetString(objv[objc-2]), "\"", NULL);
  2714  	return TCL_ERROR;
  2715      }
  2716  
  2717      for (i = 0; i < objc; i += 2) {
  2718  	/*
  2719  	 * See if the pattern matches the string.
  2720  	 */
  2721  
  2722  	pattern = Tcl_GetString(objv[i]);
  2723  
  2724  	matched = 0;
  2725  	if ((i == objc - 2) 
  2726  		&& (*pattern == 'd') 
  2727  		&& (strcmp(pattern, "default") == 0)) {
  2728  	    Tcl_Obj *emptyObj = NULL;
  2729  
  2730  	    matched = 1;
  2731  	    /*
  2732  	     * If either indexVarObj or matchVarObj are non-NULL,
  2733  	     * we're in REGEXP mode but have reached the default
  2734  	     * clause anyway.  TIP#75 specifies that we set the
  2735  	     * variables to empty lists (== empty objects) in that
  2736  	     * case.
  2737  	     */
  2738  	    if (indexVarObj != NULL) {
  2739  		TclNewObj(emptyObj);
2740 if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj,
2741 TCL_LEAVE_ERR_MSG) == NULL) { 2742 Tcl_DecrRefCount(emptyObj); 2743 return TCL_ERROR; 2744 } 2745 } 2746 if (matchVarObj != NULL) { 2747 if (emptyObj == NULL) { 2748 TclNewObj(emptyObj); 2749 } 2750 if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj, 2751 TCL_LEAVE_ERR_MSG) == NULL) { 2752 if (indexVarObj == NULL) { 2753 Tcl_DecrRefCount(emptyObj); 2754 } 2755 return TCL_ERROR; 2756 } 2757 } 2758 numMatchesSaved = 0; 2759 } else { 2760 switch (mode) { 2761 case OPT_EXACT: 2762 matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0); 2763 break; 2764 case OPT_GLOB: 2765 matched = Tcl_StringMatch(Tcl_GetString(stringObj), pattern); 2766 break; 2767 case OPT_REGEXP: 2768 regExpr = Tcl_GetRegExpFromObj(interp, objv[i], 2769 TCL_REG_ADVANCED); 2770 if (regExpr == NULL) { 2771 return TCL_ERROR; 2772 } 2773 matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0, 2774 numMatchesSaved, 0); 2775 if (matched < 0) { 2776 return TCL_ERROR; 2777 } 2778 break; 2779 } 2780 } 2781 if (matched == 0) { 2782 continue; 2783 } 2784 2785 /* 2786 * We are operating in REGEXP mode and we need to store 2787 * information about what we matched in some user-nominated 2788 * arrays. So build the lists of values and indices to write 2789 * here. [TIP#75] 2790 */ 2791 2792 if (numMatchesSaved) { 2793 Tcl_RegExpInfo info; 2794 Tcl_Obj *matchesObj, *indicesObj; 2795 2796 Tcl_RegExpGetInfo(regExpr, &info); 2797 if (matchVarObj != NULL) { 2798 TclNewObj(matchesObj); 2799 } else { 2800 matchesObj = NULL; 2801 } 2802 if (indexVarObj != NULL) { 2803 TclNewObj(indicesObj); 2804 } 2805 for (j=0 ; j<=info.nsubs ; j++) { 2806 if (indexVarObj != NULL) { 2807 Tcl_Obj *rangeObjAry[2]; 2808 2809 rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); 2810 rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); 2811 /* 2812 * Never fails; the object is always clean at this point. 2813 */ 2814 Tcl_ListObjAppendElement(NULL, indicesObj, 2815 Tcl_NewListObj(2, rangeObjAry)); 2816 } 2817 if (matchVarObj != NULL) { 2818 Tcl_Obj *substringObj; 2819 2820 substringObj = Tcl_GetRange(stringObj, 2821 info.matches[j].start, info.matches[j].end-1); 2822 /* 2823 * Never fails; the object is always clean at this point. 2824 */ 2825 Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); 2826 } 2827 } 2828 if (indexVarObj != NULL) { 2829 if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, 2830 TCL_LEAVE_ERR_MSG) == NULL) { 2831 Tcl_DecrRefCount(indicesObj); 2832 /* 2833 * Careful! Check to see if we have allocated the 2834 * list of matched strings; if so (but there was 2835 * an error assigning the indices list) we have a 2836 * potential memory leak because the match list 2837 * has not been written to a variable. Except 2838 * that we'll clean that up right now. 2839 */ 2840 if (matchesObj != NULL) { 2841 Tcl_DecrRefCount(matchesObj); 2842 } 2843 return TCL_ERROR; 2844 } 2845 } 2846 if (matchVarObj != NULL) { 2847 if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, 2848 TCL_LEAVE_ERR_MSG) == NULL) { 2849 Tcl_DecrRefCount(matchesObj); 2850 /* 2851 * Unlike above, if indicesObj is non-NULL at this 2852 * point, it will have been written to a variable 2853 * already and will hence not be leaked. 2854 */ 2855 return TCL_ERROR; 2856 } 2857 } 2858 } 2859 2860 /* 2861 * We've got a match. Find a body to execute, skipping bodies 2862 * that are "-". 2863 */ 2864 2865 for (j = i + 1; ; j += 2) { 2866 if (j >= objc) { 2867 /* 2868 * This shouldn't happen since we've checked that the 2869 * last body is not a continuation... 2870 */ 2871 panic("fall-out when searching for body to match pattern"); 2872 } 2873 if (strcmp(Tcl_GetString(objv[j]), "-") != 0) { 2874 break; 2875 } 2876 } 2877 result = Tcl_EvalObjEx(interp, objv[j], 0); 2878 if (result == TCL_ERROR) { 2879 Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); 2880 Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); 2881 Tcl_IncrRefCount(msg); 2882 Tcl_IncrRefCount(errorLine); 2883 TclAppendLimitedToObj(msg, pattern, -1, 50, ""); 2884 Tcl_AppendToObj(msg,"\" arm line ", -1); 2885 Tcl_AppendObjToObj(msg, errorLine); 2886 Tcl_DecrRefCount(errorLine); 2887 Tcl_AppendToObj(msg,")", -1); 2888 TclAppendObjToErrorInfo(interp, msg); 2889 Tcl_DecrRefCount(msg); 2890 } 2891 return result; 2892 } 2893 return TCL_OK; 2894 } 2895 2896 /* 2897 *---------------------------------------------------------------------- 2898 * 2899 * Tcl_TimeObjCmd -- 2900 * 2901 * This object-based procedure is invoked to process the "time" Tcl 2902 * command. See the user documentation for details on what it does. 2903 * 2904 * Results: 2905 * A standard Tcl object result. 2906 * 2907 * Side effects: 2908 * See the user documentation. 2909 * 2910 *---------------------------------------------------------------------- 2911 */ 2912 2913 /* ARGSUSED */ 2914 int 2915 Tcl_TimeObjCmd(dummy, interp, objc, objv) 2916 ClientData dummy; /* Not used. */ 2917 Tcl_Interp *interp; /* Current interpreter. */ 2918 int objc; /* Number of arguments. */ 2919 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2920 { 2921 register Tcl_Obj *objPtr; 2922 register int i, result; 2923 int count; 2924 double totalMicroSec; 2925 Tcl_Time start, stop; 2926 char buf[100]; 2927 2928 if (objc == 2) { 2929 count = 1; 2930 } else if (objc == 3) { 2931 result = Tcl_GetIntFromObj(interp, objv[2], &count); 2932 if (result != TCL_OK) { 2933 return result; 2934 } 2935 } else { 2936 Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); 2937 return TCL_ERROR; 2938 } 2939 2940 objPtr = objv[1]; 2941 i = count; 2942 Tcl_GetTime(&start); 2943 while (i-- > 0) { 2944 result = Tcl_EvalObjEx(interp, objPtr, 0); 2945 if (result != TCL_OK) { 2946 return result; 2947 } 2948 } 2949 Tcl_GetTime(&stop); 2950 2951 totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 2952 + ( stop.usec - start.usec ) ); 2953 sprintf(buf, "%.0f microseconds per iteration", 2954 ((count <= 0) ? 0 : totalMicroSec/count)); 2955 Tcl_ResetResult(interp); 2956 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1); 2957 return TCL_OK; 2958 } 2959 2960 /* 2961 *---------------------------------------------------------------------- 2962 * 2963 * Tcl_WhileObjCmd -- 2964 * 2965 * This procedure is invoked to process the "while" Tcl command. 2966 * See the user documentation for details on what it does. 2967 * 2968 * With the bytecode compiler, this procedure is only called when 2969 * a command name is computed at runtime, and is "while" or the name 2970 * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" 2971 * 2972 * Results: 2973 * A standard Tcl result. 2974 * 2975 * Side effects: 2976 * See the user documentation. 2977 * 2978 *---------------------------------------------------------------------- 2979 */ 2980 2981 /* ARGSUSED */ 2982 int 2983 Tcl_WhileObjCmd(dummy, interp, objc, objv) 2984 ClientData dummy; /* Not used. */ 2985 Tcl_Interp *interp; /* Current interpreter. */ 2986 int objc; /* Number of arguments. */ 2987 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2988 { 2989 int result, value; 2990 2991 if (objc != 3) { 2992 Tcl_WrongNumArgs(interp, 1, objv, "test command"); 2993 return TCL_ERROR; 2994 } 2995 2996 while (1) { 2997 result = Tcl_ExprBooleanObj(interp, objv[1], &value); 2998 if (result != TCL_OK) { 2999 return result; 3000 } 3001 if (!value) { 3002 break; 3003 } 3004 result = Tcl_EvalObjEx(interp, objv[2], 0); 3005 if ((result != TCL_OK) && (result != TCL_CONTINUE)) { 3006 if (result == TCL_ERROR) { 3007 char msg[32 + TCL_INTEGER_SPACE]; 3008 3009 sprintf(msg, "\n (\"while\" body line %d)", 3010 interp->errorLine); 3011 Tcl_AddErrorInfo(interp, msg); 3012 } 3013 break; 3014 } 3015 } 3016 if (result == TCL_BREAK) { 3017 result = TCL_OK; 3018 } 3019 if (result == TCL_OK) { 3020 Tcl_ResetResult(interp); 3021 } 3022 return result; 3023 }