diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 4593 |
1 files changed, 3166 insertions, 1427 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 094dcac..00c9f2f 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2,31 +2,76 @@ * tclCmdMZ.c -- * * This file contains the top-level command routines for most of the Tcl - * built-in commands whose names begin with the letters M to Z. It - * contains only commands in the generic core (i.e. those that don't + * built-in commands whose names begin with the letters M to Z. It + * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2003 Donal K. Fellows. + * Copyright (c) 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.127 2005/07/17 21:17:37 dkf Exp $ */ #include "tclInt.h" #include "tclRegexp.h" +#include "tclStringTrim.h" + +static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, + Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); +static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, + int result); +static int TryPostBody(ClientData data[], Tcl_Interp *interp, + int result); +static int TryPostFinal(ClientData data[], Tcl_Interp *interp, + int result); +static int TryPostHandler(ClientData data[], Tcl_Interp *interp, + int result); +static int UniCharIsAscii(int character); +static int UniCharIsHexDigit(int character); /* + * Default set of characters to trim in [string trim] and friends. This is a + * UTF-8 literal string containing all Unicode space characters [TIP #413] + */ + +const char tclDefaultTrimSet[] = + "\x09\x0a\x0b\x0c\x0d " /* ASCII */ + "\xc0\x80" /* nul (U+0000) */ + "\xc2\x85" /* next line (U+0085) */ + "\xc2\xa0" /* non-breaking space (U+00a0) */ + "\xe1\x9a\x80" /* ogham space mark (U+1680) */ + "\xe1\xa0\x8e" /* mongolian vowel separator (U+180e) */ + "\xe2\x80\x80" /* en quad (U+2000) */ + "\xe2\x80\x81" /* em quad (U+2001) */ + "\xe2\x80\x82" /* en space (U+2002) */ + "\xe2\x80\x83" /* em space (U+2003) */ + "\xe2\x80\x84" /* three-per-em space (U+2004) */ + "\xe2\x80\x85" /* four-per-em space (U+2005) */ + "\xe2\x80\x86" /* six-per-em space (U+2006) */ + "\xe2\x80\x87" /* figure space (U+2007) */ + "\xe2\x80\x88" /* punctuation space (U+2008) */ + "\xe2\x80\x89" /* thin space (U+2009) */ + "\xe2\x80\x8a" /* hair space (U+200a) */ + "\xe2\x80\x8b" /* zero width space (U+200b) */ + "\xe2\x80\xa8" /* line separator (U+2028) */ + "\xe2\x80\xa9" /* paragraph separator (U+2029) */ + "\xe2\x80\xaf" /* narrow no-break space (U+202f) */ + "\xe2\x81\x9f" /* medium mathematical space (U+205f) */ + "\xe2\x81\xa0" /* word joiner (U+2060) */ + "\xe3\x80\x80" /* ideographic space (U+3000) */ + "\xef\xbb\xbf" /* zero width no-break space (U+feff) */ +; + +/* *---------------------------------------------------------------------- * * Tcl_PwdObjCmd -- * - * This procedure is invoked to process the "pwd" Tcl command. See the + * This procedure is invoked to process the "pwd" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -38,13 +83,12 @@ *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_PwdObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_PwdObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *retVal; @@ -67,7 +111,7 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) * * Tcl_RegexpObjCmd -- * - * This procedure is invoked to process the "regexp" Tcl command. See + * This procedure is invoked to process the "regexp" Tcl command. See * the user documentation for details on what it does. * * Results: @@ -79,23 +123,22 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_RegexpObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_RegexpObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int i, indices, match, about, offset, all, doinline, numMatchesSaved; - int cflags, eflags, stringLength; + int cflags, eflags, stringLength, matchLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; - static CONST char *options[] = { + static const char *const options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", - "-nocase", "-start", "--", (char *) NULL + "-nocase", "-start", "--", NULL }; enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, @@ -103,16 +146,15 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) REGEXP_NOCASE, REGEXP_START, REGEXP_LAST }; - indices = 0; - about = 0; - cflags = TCL_REG_ADVANCED; - eflags = 0; - offset = 0; - all = 0; - doinline = 0; + indices = 0; + about = 0; + cflags = TCL_REG_ADVANCED; + offset = 0; + all = 0; + doinline = 0; for (i = 1; i < objc; i++) { - char *name; + const char *name; int index; name = TclGetString(objv[i]); @@ -156,7 +198,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) if (++i >= objc) { goto endOfForLoop; } - if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { @@ -172,10 +214,10 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } } - endOfForLoop: + endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); goto optionError; } objc -= i; @@ -187,8 +229,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) */ if (doinline && ((objc - 2) != 0)) { - Tcl_AppendResult(interp, "regexp match variables not allowed", - " when using -inline", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "regexp match variables not allowed when using -inline", -1)); goto optionError; } @@ -199,7 +241,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { - optionError: + optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); } @@ -210,7 +252,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * Get the length of the string that we are matching against so we can do - * the termination test for -all matches. Do this before getting the + * the termination test for -all matches. Do this before getting the * regexp to avoid shimmering problems. */ @@ -218,7 +260,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndex(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; @@ -230,15 +272,6 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - if (offset > 0) { - /* - * Add flag if using offset (string is part of a larger string), so - * that "^" won't match. - */ - - eflags |= TCL_REG_NOTBOL; - } - objc -= 2; objv += 2; @@ -260,18 +293,32 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * The following loop is to handle multiple matches within the same source - * string; each iteration handles one match. If "-all" hasn't been - * specified then the loop body only gets executed once. We terminate the + * string; each iteration handles one match. If "-all" hasn't been + * specified then the loop body only gets executed once. We terminate the * loop when the starting offset is past the end of the string. */ while (1) { - match = Tcl_RegExpExecObj(interp, regExpr, objPtr, - offset /* offset */, numMatchesSaved, eflags - | ((offset > 0 && - (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + /* + * Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing + * TCL_REG_NOTBOL indicates that the character at offset should not be + * considered the start of the line. If for example the pattern {^} is + * passed and -start is positive, then the pattern will not match the + * start of the string unless the previous character is a newline. + */ + if (offset == 0) { + eflags = 0; + } else if (offset > stringLength) { + eflags = TCL_REG_NOTBOL; + } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + eflags = 0; + } else { + eflags = TCL_REG_NOTBOL; + } + + match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, + numMatchesSaved, eflags); if (match < 0) { return TCL_ERROR; } @@ -323,12 +370,12 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * Only adjust the match area if there was a match for that - * area. (Scriptics Bug 4391/SF Bug #219232) + * area. (Scriptics Bug 4391/SF Bug #219232) */ if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; - end = offset + info.matches[i].end; + end = offset + info.matches[i].end; /* * Adjust index so it refers to the last character in the @@ -340,7 +387,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } } else { start = -1; - end = -1; + end = -1; } objs[0] = Tcl_NewLongObj(start); @@ -364,12 +411,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } else { - Tcl_Obj *valuePtr; - valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); - if (valuePtr == NULL) { - Tcl_DecrRefCount(newPtr); - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[i]), "\"", (char *) NULL); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -382,19 +425,26 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * Adjust the offset to the character just after the last one in the * matchVar and increment all to count how many times we are making a - * match. We always increment the offset by at least one to prevent - * endless looping (as in the case: regexp -all {a*} a). Otherwise, + * match. We always increment the offset by at least one to prevent + * endless looping (as in the case: regexp -all {a*} a). Otherwise, * when we match the NULL string at the end of the input string, we * will loop indefinately (because the length of the match is 0, so * offset never changes). */ - if (info.matches[0].end == 0) { + matchLength = (info.matches[0].end - info.matches[0].start); + + offset += info.matches[0].end; + + /* + * A match of length zero could happen for {^} {$} or {.*} and in + * these cases we always want to bump the index up one. + */ + + if (matchLength == 0) { offset++; } - offset += info.matches[0].end; all++; - eflags |= TCL_REG_NOTBOL; if (offset >= stringLength) { break; } @@ -419,8 +469,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * * Tcl_RegsubObjCmd -- * - * This procedure is invoked to process the "regsub" Tcl command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the "regsub" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -431,13 +481,12 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_RegsubObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_RegsubObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; @@ -446,7 +495,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static CONST char *options[] = { + static const char *const options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL @@ -463,7 +512,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) resultPtr = NULL; for (idx = 1; idx < objc; idx++) { - char *name; + const char *name; int index; name = TclGetString(objv[idx]); @@ -498,7 +547,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (++idx >= objc) { goto endOfForLoop; } - if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { @@ -517,7 +566,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string subSpec ?varName?"); + "?-switch ...? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -531,7 +580,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (startIndex) { int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndex(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; @@ -542,28 +591,27 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* - * This is a simple one pair string map situation. We make use of a + * This is a simple one pair string map situation. We make use of a * slightly modified version of the one pair STR_MAP code. */ int slen, nocase; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, - unsigned long)); + int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); Tcl_UniChar *p, wsrclc; numMatches = 0; - nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + nocase = (cflags & TCL_REG_NOCASE); + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); + wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); + wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); - wend = wstring + wlen - (slen ? slen - 1 : 0); - result = TCL_OK; + wend = wstring + wlen - (slen ? slen - 1 : 0); + result = TCL_OK; if (slen == 0) { /* - * regsub behavior for "" matches between each character. 'string + * regsub behavior for "" matches between each character. 'string * map' skips the "" case. */ @@ -616,7 +664,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } /* - * Make sure to avoid problems where the objects are shared. This can + * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. * [Bug #461322] */ @@ -639,8 +687,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) /* * The following loop is to handle multiple matches within the same source * string; each iteration handles one match and its corresponding - * substitution. If "-all" hasn't been specified then the loop body only - * gets executed once. We must use 'offset <= wlen' in particular for the + * substitution. If "-all" hasn't been specified then the loop body only + * gets executed once. We must use 'offset <= wlen' in particular for the * case where the regexp pattern can match the empty string - this is * useful when doing, say, 'regsub -- ^ $str ...' when $str might be * empty. @@ -656,8 +704,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, 10 /* matches */, ((offset > 0 && - (wstring[offset-1] != (Tcl_UniChar)'\n')) - ? TCL_REG_NOTBOL : 0)); + (wstring[offset-1] != (Tcl_UniChar)'\n')) + ? TCL_REG_NOTBOL : 0)); if (match < 0) { result = TCL_ERROR; @@ -692,7 +740,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) /* * Append the subSpec argument to the variable, making appropriate - * substitutions. This code is a bit hairy because of the backslash + * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in * subSpec to reduce the number of calls to Tcl_SetVar. */ @@ -779,7 +827,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * result variable. */ - regsubDone: + regsubDone: if (numMatches == 0) { /* * On zero matches, just ignore the offset, since it shouldn't matter @@ -792,9 +840,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", (char *) NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* @@ -812,7 +859,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_SetObjResult(interp, resultPtr); } - done: + done: if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } @@ -830,8 +877,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * * Tcl_RenameObjCmd -- * - * This procedure is invoked to process the "rename" Tcl command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the "rename" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -842,15 +889,14 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_RenameObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Arbitrary value passed to the command. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_RenameObjCmd( + ClientData dummy, /* Arbitrary value passed to the command. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - char *oldName, *newName; + const char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); @@ -879,13 +925,12 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_ReturnObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_ReturnObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int code, level; Tcl_Obj *returnOpts; @@ -915,8 +960,8 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) * * Tcl_SourceObjCmd -- * - * This procedure is invoked to process the "source" Tcl command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the "source" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -927,15 +972,24 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_SourceObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_SourceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv); +} + +int +TclNRSourceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - CONST char *encodingName = NULL; + const char *encodingName = NULL; Tcl_Obj *fileName; if (objc != 2 && objc !=4) { @@ -946,19 +1000,19 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) fileName = objv[objc-1]; if (objc == 4) { - static CONST char *options[] = { - "-encoding", (char *) NULL + static const char *const options[] = { + "-encoding", NULL }; int index; - if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], - options, "option", TCL_EXACT, &index)) { + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, + "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } - return Tcl_FSEvalFileEx(interp, fileName, encodingName); + return TclNREvalFile(interp, fileName, encodingName); } /* @@ -966,7 +1020,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) * * Tcl_SplitObjCmd -- * - * This procedure is invoked to process the "split" Tcl command. See the + * This procedure is invoked to process the "split" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -978,17 +1032,18 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_SplitObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_SplitObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch; int len; - char *splitChars, *stringPtr, *end; + const char *splitChars; + const char *stringPtr; + const char *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; @@ -996,13 +1051,13 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) splitChars = " \n\t\r"; splitCharLen = 4; } else if (objc == 3) { - splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen); + splitChars = TclGetStringFromObj(objv[2], &splitCharLen); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); return TCL_ERROR; } - stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); + stringPtr = TclGetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; listPtr = Tcl_NewObj(); @@ -1019,7 +1074,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * Handle the special case of splitting on every character. * * Uses a hash table to ensure that each kind of character has only - * one Tcl_Obj instance (multiply-referenced) in the final list. This + * one Tcl_Obj instance (multiply-referenced) in the final list. This * is a *major* win when splitting on a long string (especially in the * megabyte range!) - DKF */ @@ -1033,17 +1088,18 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), + &isNew); if (isNew) { - objPtr = Tcl_NewStringObj(stringPtr, len); + TclNewStringObj(objPtr, stringPtr, len); /* * Don't need to fiddle with refcount... */ - Tcl_SetHashValue(hPtr, (ClientData) objPtr); + Tcl_SetHashValue(hPtr, objPtr); } else { - objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); + objPtr = Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } @@ -1053,9 +1109,9 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) char *p; /* - * Handle the special case of splitting on a single character. This - * is only true for the one-char ASCII case, as one unicode char is > - * 1 byte in length. + * Handle the special case of splitting on a single character. This is + * only true for the one-char ASCII case, as one unicode char is > 1 + * byte in length. */ while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { @@ -1063,15 +1119,15 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) Tcl_ListObjAppendElement(NULL, listPtr, objPtr); stringPtr = p + 1; } - objPtr = Tcl_NewStringObj(stringPtr, end - stringPtr); + TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { - char *element, *p, *splitEnd; + const char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; /* - * Normal case: split on any of a given set of characters. Discard + * Normal case: split on any of a given set of characters. Discard * instances of the split characters. */ @@ -1082,7 +1138,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) for (p = splitChars; p < splitEnd; p += splitLen) { splitLen = TclUtfToUniChar(p, &splitChar); if (ch == splitChar) { - objPtr = Tcl_NewStringObj(element, stringPtr - element); + TclNewStringObj(objPtr, element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); element = stringPtr + len; break; @@ -1090,7 +1146,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) } } - objPtr = Tcl_NewStringObj(element, stringPtr - element); + TclNewStringObj(objPtr, element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_SetObjResult(interp, listPtr); @@ -1100,17 +1156,12 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * Tcl_StringObjCmd -- + * StringFirstCmd -- * - * This procedure is invoked to process the "string" Tcl command. See - * the user documentation for details on what it does. Note that this + * This procedure is invoked to process the "string first" Tcl command. + * See the user documentation for details on what it does. Note that this * command only functions correctly on properly formed Tcl UTF strings. * - * Note that the primary methods here (equal, compare, match, ...) have - * bytecode equivalents. You will find the code for those in - * tclExecute.c. The code here will only be used in the non-bc case - * (like in an 'eval'). - * * Results: * A standard Tcl result. * @@ -1120,364 +1171,409 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ -int -Tcl_StringObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +static int +StringFirstCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int index, left, right; - char *string1, *string2; - int length1, length2; - static CONST char *options[] = { - "bytelength", "compare", "equal", "first", - "index", "is", "last", "length", - "map", "match", "range", "repeat", - "replace", "tolower", "toupper", "totitle", - "trim", "trimleft", "trimright", - "wordend", "wordstart", (char *) NULL - }; - enum options { - STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST, - STR_INDEX, STR_IS, STR_LAST, STR_LENGTH, - STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT, - STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, - STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, - STR_WORDEND, STR_WORDSTART - }; + Tcl_UniChar *needleStr, *haystackStr; + int match, start, needleLen, haystackLen; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "needleString haystackString ?startIndex?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } + /* + * We are searching haystackStr for the sequence needleStr. + */ + + match = -1; + start = 0; + haystackLen = -1; - switch ((enum options) index) { - case STR_EQUAL: - case STR_COMPARE: { + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + + if (objc == 4) { /* - * Remember to keep code here in some sync with the byte-compiled - * versions in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and - * INST_STR_CMP as well as the expr string comparison in - * INST_EQ/INST_NEQ/INST_LT/...). + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. */ - int i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *, - unsigned int)); - strCmpFn_t strCmpFn; - - if (objc < 4 || objc > 7) { - str_cmp_args: - Tcl_WrongNumArgs(interp, 2, objv, - "?-nocase? ?-length int? string1 string2"); + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } - for (i = 2; i < objc-2; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) - && strncmp(string2, "-nocase", (size_t)length2) == 0) { - nocase = 1; - } else if ((length2 > 1) - && strncmp(string2, "-length", (size_t)length2) == 0) { - if (i+1 >= objc-2) { - goto str_cmp_args; - } - if (Tcl_GetIntFromObj(interp, objv[++i], - &reqlength) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", (char *) NULL); - return TCL_ERROR; - } - } - /* - * From now on, we only access the two objects at the end of the - * argument array. + * Reread to prevent shimmering problems. */ - objv += objc-2; + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if ((reqlength == 0) || (objv[0] == objv[1])) { + if (start >= haystackLen) { + goto str_first_done; + } else if (start > 0) { + haystackStr += start; + haystackLen -= start; + } else if (start < 0) { /* - * Always match at 0 chars of if it is the same obj. + * Invalid start index mapped to string start; Bug #423581 */ - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); - break; - } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some - * reason... :^) - */ + start = 0; + } + } - string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of - * String type. In benchmark testing this proved the most - * efficient check between the unicode and string comparison - * operations. - */ + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ - string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); - } else { + if (needleLen > 0 && needleLen <= haystackLen) { + register Tcl_UniChar *p, *end; + + end = haystackStr + haystackLen - needleLen + 1; + for (p = haystackStr; p < end; p++) { /* - * As a catch-all we will work with UTF-8. We cannot use memcmp() - * as that is unsafe with any string containing NULL (\xC0\x80 in - * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if - * we are case-sensitive and no specific length was requested. + * Scan forward to find the first character. */ - string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, + (unsigned long) needleLen) == 0)) { + match = p - haystackStr; + break; } } + } - if (((enum options) index == STR_EQUAL) - && (reqlength < 0) && (length1 != length2)) { - match = 1; /* this will be reversed below */ - } else { - length = (length1 < length2) ? length1 : length2; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by - * setting it to length + 1 so we correct the match var. - */ + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ - reqlength = length + 1; - } + if ((match != -1) && (objc == 4)) { + match += start; + } - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } - } + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringLastCmd -- + * + * This procedure is invoked to process the "string last" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if ((enum options) index == STR_EQUAL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj( - (match > 0) ? 1 : (match < 0) ? -1 : 0)); - } - break; +static int +StringLastCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar *needleStr, *haystackStr, *p; + int match, start, needleLen, haystackLen; + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "needleString haystackString ?startIndex?"); + return TCL_ERROR; } - case STR_FIRST: { - Tcl_UniChar *ustring1, *ustring2; - int match, start; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); + /* + * We are searching haystackString for the sequence needleString. + */ + + match = -1; + start = 0; + haystackLen = -1; + + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + + if (objc == 4) { + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ + + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } /* - * We are searching string2 for the sequence string1. + * Reread to prevent shimmering problems. */ - match = -1; - start = 0; - length2 = -1; + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + if (start < 0) { + goto str_last_done; + } else if (start < haystackLen) { + p = haystackStr + start + 1 - needleLen; + } else { + p = haystackStr + haystackLen - needleLen; + } + } else { + p = haystackStr + haystackLen - needleLen; + } - if (objc == 5) { + /* + * If the length of the needle is more than the length of the haystack, it + * cannot be contained in there so we can avoid searching. [Bug 2960021] + */ + + if (needleLen > 0 && needleLen <= haystackLen) { + for (; p >= haystackStr; p--) { /* - * If a startIndex is specified, we will need to fast forward to - * that point in the string before we think about a match + * Scan backwards to find the first character. */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start >= length2) { - goto str_first_done; - } else if (start > 0) { - ustring2 += start; - length2 -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; Bug #423581 - */ - - start = 0; + if ((*p == *needleStr) && !memcmp(needleStr, p, + sizeof(Tcl_UniChar) * (size_t)needleLen)) { + match = p - haystackStr; + break; } } + } - if (length1 > 0) { - register Tcl_UniChar *p, *end; + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringIndexCmd -- + * + * This procedure is invoked to process the "string index" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - end = ustring2 + length2 - length1 + 1; - for (p = ustring2; p < end; p++) { - /* - * Scan forward to find the first character. - */ - if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, - (unsigned long) length1) == 0)) { - match = p - ustring2; - break; - } - } - } +static int +StringIndexCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length, index; - /* - * Compute the character index of the matching string by counting the - * number of characters before the match. - */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); + return TCL_ERROR; + } - if ((match != -1) && (objc == 5)) { - match += start; - } + /* + * Get the char length to calulate what 'end' means. + */ - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); - break; + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { + return TCL_ERROR; } - case STR_INDEX: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); - return TCL_ERROR; - } + + if ((index >= 0) && (index < length)) { + Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index); /* - * If we have a ByteArray object, avoid indexing in the Utf string - * since the byte array contains one byte per character. Otherwise, - * use the Unicode string rep to get the index'th char. + * If we have a ByteArray object, we're careful to generate a new + * bytearray for a result. */ - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); + if (TclIsPureByteArray(objv[1])) { + unsigned char uch = (unsigned char) ch; - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *)(&string1[index]), 1)); - } + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); } else { - /* - * Get Unicode char length to calulate what 'end' means. - */ - - length1 = Tcl_GetCharLength(objv[2]); + char buf[TCL_UTF_MAX]; - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch; - - ch = Tcl_GetUniChar(objv[2], index); - length1 = Tcl_UniCharToUtf(ch, buf); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); - } + length = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } - break; } - case STR_IS: { - char *end; - Tcl_UniChar ch; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringIsCmd -- + * + * This procedure is invoked to process the "string is" Tcl command. See + * the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - /* - * The UniChar comparison function - */ +static int +StringIsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1, *end, *stop; + Tcl_UniChar ch; + int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ + int i, failat = 0, result = 1, strict = 0, index, length1, length2; + Tcl_Obj *objPtr, *failVarObj = NULL; + Tcl_WideInt w; + + static const char *const isClasses[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL + }; + enum isClasses { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT + }; + static const char *const isOptions[] = { + "-strict", "-failindex", NULL + }; + enum isOptions { + OPT_STRICT, OPT_FAILIDX + }; - int (*chcomp)_ANSI_ARGS_((int)) = NULL; - int i, failat = 0, result = 1, strict = 0; - Tcl_Obj *objPtr, *failVarObj = NULL; - Tcl_WideInt w; - - static CONST char *isOptions[] = { - "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "false", - "graph", "integer", "lower", "print", - "punct", "space", "true", "upper", - "wideinteger", "wordchar", "xdigit", (char *) NULL - }; - enum isOptions { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, - STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, - STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, - STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; + if (objc < 3 || objc > 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "class ?-strict? ?-failindex var? str"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], isClasses, "class", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } - if (objc < 4 || objc > 7) { - Tcl_WrongNumArgs(interp, 2, objv, - "class ?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (objc != 4) { - for (i = 3; i < objc-1; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) && - strncmp(string2, "-strict", (size_t) length2) == 0) { - strict = 1; - } else if ((length2 > 1) && - strncmp(string2, "-failindex", (size_t) length2) == 0){ - if (i+1 >= objc-1) { - Tcl_WrongNumArgs(interp, 3, objv, - "?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - failVarObj = objv[++i]; - } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -strict or -failindex", (char *)NULL); + if (objc != 3) { + for (i = 2; i < objc-1; i++) { + int idx2; + + if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, + &idx2) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum isOptions) idx2) { + case OPT_STRICT: + strict = 1; + break; + case OPT_FAILIDX: + if (i+1 >= objc-1) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-strict? ?-failindex var? str"); return TCL_ERROR; } + failVarObj = objv[++i]; + break; } } + } - /* - * We get the objPtr so that we can short-cut for some classes by - * checking the object type (int and double), but we need the string - * otherwise, because we don't want any conversion of type occuring - * (as, for example, Tcl_Get*FromObj would do - */ + /* + * We get the objPtr so that we can short-cut for some classes by checking + * the object type (int and double), but we need the string otherwise, + * because we don't want any conversion of type occuring (as, for example, + * Tcl_Get*FromObj would do). + */ + + objPtr = objv[objc-1]; + + /* + * When entering here, result == 1 and failat == 0. + */ - objPtr = objv[objc-1]; - string1 = Tcl_GetStringFromObj(objPtr, &length1); + switch ((enum isClasses) index) { + case STR_IS_ALNUM: + chcomp = Tcl_UniCharIsAlnum; + break; + case STR_IS_ALPHA: + chcomp = Tcl_UniCharIsAlpha; + break; + case STR_IS_ASCII: + chcomp = UniCharIsAscii; + break; + case STR_IS_BOOL: + case STR_IS_TRUE: + case STR_IS_FALSE: + if ((objPtr->typePtr != &tclBooleanType) + && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { + if (strict) { + result = 0; + } else { + string1 = TclGetStringFromObj(objPtr, &length1); + result = length1 == 0; + } + } else if (((index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) + || ((index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { + result = 0; + } + break; + case STR_IS_CONTROL: + chcomp = Tcl_UniCharIsControl; + break; + case STR_IS_DIGIT: + chcomp = Tcl_UniCharIsDigit; + break; + case STR_IS_DOUBLE: { + /* TODO */ + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { + break; + } + string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; @@ -1485,992 +1581,1788 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) goto str_is_done; } end = string1 + length1; - - /* - * When entering here, result == 1 and failat == 0 - */ - - switch ((enum isOptions) index) { - case STR_IS_ALNUM: - chcomp = Tcl_UniCharIsAlnum; - break; - case STR_IS_ALPHA: - chcomp = Tcl_UniCharIsAlpha; - break; - case STR_IS_ASCII: - for (; string1 < end; string1++, failat++) { - /* - * This is a valid check in unicode, because all bytes less - * than 0xC0 are single byte chars (but isascii limits that - * def'n to 0x80). - */ - - if (*((unsigned char *)string1) >= 0x80) { - result = 0; - break; - } - } - break; - case STR_IS_BOOL: - case STR_IS_TRUE: - case STR_IS_FALSE: - if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { - result = 0; - } else if ((((enum isOptions) index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) || - (((enum isOptions) index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, 0) != TCL_OK) { + result = 0; + failat = 0; + } else { + failat = stop - string1; + if (stop < end) { result = 0; + TclFreeIntRep(objPtr); } + } + break; + } + case STR_IS_GRAPH: + chcomp = Tcl_UniCharIsGraph; + break; + case STR_IS_INT: + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { break; - case STR_IS_CONTROL: - chcomp = Tcl_UniCharIsControl; - break; - case STR_IS_DIGIT: - chcomp = Tcl_UniCharIsDigit; - break; - case STR_IS_DOUBLE: { - char *stop; - - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType)) { - break; - } - - /* - * This is adapted from Tcl_GetDouble - * - * The danger in this function is that "12345678901234567890" is - * an acceptable 'double', but will later be interp'd as an int by - * something like [expr]. Therefore, we check to see if it looks - * like an int, and if so we do a range check on it. If strtoul - * gets to the end, we know we either received an acceptable int, - * or over/underflow. - */ - - if (TclLooksLikeInt(string1, length1)) { - errno = 0; -#ifdef TCL_WIDE_INT_IS_LONG - strtoul(string1, &stop, 0); /* INTL: Tcl source. */ -#else - strtoull(string1, &stop, 0); /* INTL: Tcl source. */ + } + goto failedIntParse; + case STR_IS_ENTIER: + if ((objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG + (objPtr->typePtr == &tclWideIntType) || #endif - if (stop == end) { - if (errno == ERANGE) { - result = 0; - failat = -1; - } - break; - } + (objPtr->typePtr == &tclBignumType)) { + break; + } + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; } - errno = 0; - TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */ - if (stop == string1) { + goto str_is_done; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { /* - * In this case, nothing like a number was found. + * Entire string parses as an integer. */ - result = 0; - failat = 0; + break; } else { /* - * Assume we sucked up one char per byte and then we go onto - * SPACE, since we are allowed trailing whitespace. + * Some prefix parsed as an integer, but not the whole string, + * so return failure index as the point where parsing stopped. + * Clear out the internal rep, since keeping it would leave + * *objPtr in an inconsistent state. */ + result = 0; failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; + TclFreeIntRep(objPtr); } - break; + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ + + result = 0; + failat = 0; } - case STR_IS_GRAPH: - chcomp = Tcl_UniCharIsGraph; + break; + case STR_IS_WIDE: + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; - case STR_IS_INT: { - char *stop; - long int l = 0; + } - if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { - break; + failedIntParse: + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; } - + goto str_is_done; + } + result = 0; + if (failVarObj == NULL) { /* - * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj - * already failed, we set result to 0. + * Don't bother computing the failure point if we're not going to + * return it. */ - result = 0; - errno = 0; - l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ - if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { + break; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { /* - * if (errno == ERANGE) or the long value won't fit in an int, - * then it was an over/underflow problem, but in this method, - * we only want to know yes or no, so bad flow returns 0 - * (false) and sets the failVarObj to the string length. + * Entire string parses as an integer, but rejected by + * Tcl_Get(Wide)IntFromObj() so we must have overflowed the + * target type, and our convention is to return failure at + * index -1 in that situation. */ failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - - failat = 0; } else { /* - * Assume we sucked up one char per byte and then we go onto - * SPACE, since we are allowed trailing whitespace. + * Some prefix parsed as an integer, but not the whole string, + * so return failure index as the point where parsing stopped. + * Clear out the internal rep, since keeping it would leave + * *objPtr in an inconsistent state. */ failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; + TclFreeIntRep(objPtr); } - break; + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ + + failat = 0; } - case STR_IS_LOWER: - chcomp = Tcl_UniCharIsLower; - break; - case STR_IS_PRINT: - chcomp = Tcl_UniCharIsPrint; - break; - case STR_IS_PUNCT: - chcomp = Tcl_UniCharIsPunct; - break; - case STR_IS_SPACE: - chcomp = Tcl_UniCharIsSpace; - break; - case STR_IS_UPPER: - chcomp = Tcl_UniCharIsUpper; - break; - case STR_IS_WIDE: { - char *stop; + break; + case STR_IS_LIST: + /* + * We ignore the strictness here, since empty strings are always + * well-formed lists. + */ - if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { - break; - } + if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { + break; + } + if (failVarObj != NULL) { /* - * Like STR_IS_DOUBLE, but we use strtoll. Since - * Tcl_GetWideIntFromObj already failed, we set result to 0. + * Need to figure out where the list parsing failed, which is + * fairly expensive. This is adapted from the core of + * SetListFromAny(). */ - result = 0; - errno = 0; - w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ - if (errno == ERANGE) { - /* - * if (errno == ERANGE), then it was an over/underflow - * problem, but in this method, we only want to know yes or - * no, so bad flow returns 0 (false) and sets the failVarObj - * to the string length. - */ + const char *elemStart, *nextElem; + int lenRemain, elemSize; + register const char *p; - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - failat = 0; - } else { - /* - * Assume we sucked up one char per byte and then we go onto - * SPACE, since we are allowed trailing whitespace. - */ + string1 = TclGetStringFromObj(objPtr, &length1); + end = string1 + length1; + failat = -1; + for (p=string1, lenRemain=length1; lenRemain > 0; + p=nextElem, lenRemain=end-nextElem) { + if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, + &elemStart, &nextElem, &elemSize, NULL)) { + Tcl_Obj *tmpStr; - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; - } - break; - } - case STR_IS_WORD: - chcomp = Tcl_UniCharIsWordChar; - break; - case STR_IS_XDIGIT: - for (; string1 < end; string1++, failat++) { - /* INTL: We assume unicode is bad for this class */ - if ((*((unsigned char *)string1) >= 0xC0) || - !isxdigit(*(unsigned char *)string1)) { - result = 0; + /* + * This is the simplest way of getting the number of + * characters parsed. Note that this is not the same as + * the number of bytes when parsing strings with non-ASCII + * characters in them. + * + * Skip leading spaces first. This is only really an issue + * if it is the first "element" that has the failure. + */ + + while (TclIsSpaceProc(*p)) { + p++; + } + TclNewStringObj(tmpStr, string1, p-string1); + failat = Tcl_GetCharLength(tmpStr); + TclDecrRefCount(tmpStr); break; } } - break; } - if (chcomp != NULL) { - for (; string1 < end; string1 += length2, failat++) { - length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { - result = 0; - break; - } + result = 0; + break; + case STR_IS_LOWER: + chcomp = Tcl_UniCharIsLower; + break; + case STR_IS_PRINT: + chcomp = Tcl_UniCharIsPrint; + break; + case STR_IS_PUNCT: + chcomp = Tcl_UniCharIsPunct; + break; + case STR_IS_SPACE: + chcomp = Tcl_UniCharIsSpace; + break; + case STR_IS_UPPER: + chcomp = Tcl_UniCharIsUpper; + break; + case STR_IS_WORD: + chcomp = Tcl_UniCharIsWordChar; + break; + case STR_IS_XDIGIT: + chcomp = UniCharIsHexDigit; + break; + } + + if (chcomp != NULL) { + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; } + goto str_is_done; } + end = string1 + length1; + for (; string1 < end; string1 += length2, failat++) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { + result = 0; + break; + } + } + } - /* - * Only set the failVarObj when we will return 0 and we have indicated - * a valid fail index (>= 0). - */ + /* + * Only set the failVarObj when we will return 0 and we have indicated a + * valid fail index (>= 0). + */ - str_is_done: - if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - break; + str_is_done: + if ((result == 0) && (failVarObj != NULL) && + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +UniCharIsAscii( + int character) +{ + return (character >= 0) && (character < 0x80); +} + +static int +UniCharIsHexDigit( + int character) +{ + return (character >= 0) && (character < 0x80) && isxdigit(character); +} + +/* + *---------------------------------------------------------------------- + * + * StringMapCmd -- + * + * This procedure is invoked to process the "string map" Tcl command. See + * the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringMapCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2, mapElemc, index; + int nocase = 0, mapWithDict = 0, copySource = 0; + Tcl_Obj **mapElemv, *sourceObj, *resultPtr; + Tcl_UniChar *ustring1, *ustring2, *p, *end; + int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); + + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); + return TCL_ERROR; } - case STR_LAST: { - Tcl_UniChar *ustring1, *ustring2, *p; - int match, start; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); + if (objc == 4) { + const char *string = TclGetStringFromObj(objv[1], &length2); + + if ((length2 > 1) && + strncmp(string, "-nocase", (size_t) length2) == 0) { + nocase = 1; + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } + } - /* - * We are searching string2 for the sequence string1. - */ + /* + * This test is tricky, but has to be that way or you get other strange + * inconsistencies (see test string-10.20 for illustration why!) + */ - match = -1; - start = 0; - length2 = -1; + if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + int i, done; + Tcl_DictSearch search; - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + /* + * We know the type exactly, so all dict operations will succeed for + * sure. This shortens this code quite a bit. + */ - if (objc == 5) { + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { /* - * If a startIndex is specified, we will need to restrict the - * string range to that char index in the string + * Empty charMap, just return whatever string was given. */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start < 0) { - goto str_last_done; - } else if (start < length2) { - p = ustring2 + start + 1 - length1; - } else { - p = ustring2 + length2 - length1; - } - } else { - p = ustring2 + length2 - length1; + Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; } - if (length1 > 0) { - for (; p >= ustring2; p--) { - /* - * Scan backwards to find the first character. - */ + mapElemc *= 2; + mapWithDict = 1; - if ((*p == *ustring1) && - (memcmp((char *) ustring1, (char *) p, (size_t) - (length1 * sizeof(Tcl_UniChar))) == 0)) { - match = p - ustring2; - break; - } - } - } + /* + * Copy the dictionary out into an array; that's the easiest way to + * adapt this code... + */ - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); - break; - } - case STR_BYTELENGTH: - case STR_LENGTH: - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); + mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, + mapElemv+1, &done); + for (i=2 ; i<mapElemc ; i+=2) { + Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); + } + Tcl_DictObjDone(&search); + } else { + if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, + &mapElemv) != TCL_OK) { return TCL_ERROR; } + if (mapElemc == 0) { + /* + * empty charMap, just return whatever string was given. + */ - if ((enum options) index == STR_BYTELENGTH) { - (void) Tcl_GetStringFromObj(objv[2], &length1); - } else { + Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; + } else if (mapElemc & 1) { /* - * If we have a ByteArray object, avoid recomputing the string - * since the byte array contains one byte per character. - * Otherwise, use the Unicode string rep to calculate the length. + * The charMap must be an even number of key/value items. */ - if (objv[2]->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(objv[2], &length1); - } else { - length1 = Tcl_GetCharLength(objv[2]); - } - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); - break; - case STR_MAP: { - int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; - Tcl_Obj **mapElemv, *sourceObj, *resultPtr; - Tcl_UniChar *ustring1, *ustring2, *p, *end; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, - unsigned long)); - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } + } - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase", (char *) NULL); - return TCL_ERROR; - } - } + /* + * Take a copy of the source string object if it is the same as the map + * string to cut out nasty sharing crashes. [Bug 1018562] + */ + if (objv[objc-2] == objv[objc-1]) { + sourceObj = Tcl_DuplicateObj(objv[objc-1]); + copySource = 1; + } else { + sourceObj = objv[objc-1]; + } + ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); + if (length1 == 0) { /* - * This test is tricky, but has to be that way or you get other - * strange inconsistencies (see test string-10.20 for illustration - * why!) + * Empty input string, just stop now. */ - if (objv[objc-2]->typePtr == &tclDictType && - objv[objc-2]->bytes == NULL) { - int i, done; - Tcl_DictSearch search; + goto done; + } + end = ustring1 + length1; - /* - * We know the type exactly, so all dict operations will succeed - * for sure. This shortens this code quite a bit. - */ + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); - Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); - if (mapElemc == 0) { - /* - * empty charMap, just return whatever string was given - */ + /* + * Force result to be Unicode + */ - Tcl_SetObjResult(interp, objv[objc-1]); - return TCL_OK; - } + resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + + if (mapElemc == 2) { + /* + * Special case for one map pair which avoids the extra for loop and + * extra calls to get Unicode data. The algorithm is otherwise + * identical to the multi-pair case. This will be >30% faster on + * larger strings. + */ - mapElemc *= 2; - mapWithDict = 1; + int mapLen; + Tcl_UniChar *mapString, u2lc; + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + p = ustring1; + if ((length2 > length1) || (length2 == 0)) { /* - * Copy the dictionary out into an array; that's the easiest way - * to adapt this code... + * Match string is either longer than input or empty. */ - mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc); - Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, - mapElemv+1, &done); - for (i=2 ; i<mapElemc ; i+=2) { - Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); - } + ustring1 = end; } else { - if (Tcl_ListObjGetElements(interp, objv[objc-2], - &mapElemc, &mapElemv) != TCL_OK) { - return TCL_ERROR; - } - if (mapElemc == 0) { - /* - * empty charMap, just return whatever string was given. - */ - - Tcl_SetObjResult(interp, objv[objc-1]); - return TCL_OK; - } else if (mapElemc & 1) { - /* - * The charMap must be an even number of key/value items. - */ + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); + for (; ustring1 < end; ustring1++) { + if (((*ustring1 == *ustring2) || + (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && + (length2==1 || strCmpFn(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "char map list unbalanced", -1)); - return TCL_ERROR; + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + } } } + } else { + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; /* - * Take a copy of the source string object if it is the same as the - * map string to cut out nasty sharing crashes. [Bug 1018562] + * Precompute pointers to the unicode string and length. This saves us + * repeated function calls later, significantly speeding up the + * algorithm. We only need the lowercase first char in the nocase + * case. */ - if (objv[objc-2] == objv[objc-1]) { - sourceObj = Tcl_DuplicateObj(objv[objc-1]); - copySource = 1; - } else { - sourceObj = objv[objc-1]; + mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); + mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); + if (nocase) { + u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); - if (length1 == 0) { - /* - * Empty input string, just stop now. - */ - - if (mapWithDict) { - ckfree((char *) mapElemv); - } - if (copySource) { - Tcl_DecrRefCount(sourceObj); + for (index = 0; index < mapElemc; index++) { + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + mapLens+index); + if (nocase && ((index % 2) == 0)) { + u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); } - break; } - end = ustring1 + length1; + for (p = ustring1; ustring1 < end; ustring1++) { + for (index = 0; index < mapElemc; index += 2) { + /* + * Get the key string to match on. + */ - strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + ustring2 = mapStrings[index]; + length2 = mapLens[index]; + if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && + (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && + /* Restrict max compare length. */ + (end-ustring1 >= length2) && ((length2 == 1) || + !strCmpFn(ustring2, ustring1, (unsigned) length2))) { + if (p != ustring1) { + /* + * Put the skipped chars onto the result first. + */ + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + p = ustring1 + length2; + } else { + p += length2; + } + + /* + * Adjust len to be full length of matched string. + */ + + ustring1 = p - 1; + + /* + * Append the map value to the unicode string. + */ + + Tcl_AppendUnicodeToObj(resultPtr, + mapStrings[index+1], mapLens[index+1]); + break; + } + } + } + if (nocase) { + TclStackFree(interp, u2lc); + } + TclStackFree(interp, mapLens); + TclStackFree(interp, mapStrings); + } + if (p != ustring1) { /* - * Force result to be Unicode + * Put the rest of the unmapped chars onto result. */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); - if (mapElemc == 2) { - /* - * Special case for one map pair which avoids the extra for loop - * and extra calls to get Unicode data. The algorithm is otherwise - * identical to the multi-pair case. This will be >30% faster on - * larger strings. - */ + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + } + Tcl_SetObjResult(interp, resultPtr); + done: + if (mapWithDict) { + TclStackFree(interp, mapElemv); + } + if (copySource) { + Tcl_DecrRefCount(sourceObj); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringMatchCmd -- + * + * This procedure is invoked to process the "string match" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - int mapLen; - Tcl_UniChar *mapString, u2lc; +static int +StringMatchCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int nocase = 0; - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); - p = ustring1; - if ((length2 > length1) || (length2 == 0)) { - /* - * Match string is either longer than input or empty. - */ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); + return TCL_ERROR; + } - ustring1 = end; - } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); - u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); - for (; ustring1 < end; ustring1++) { - if (((*ustring1 == *ustring2) || - (nocase && Tcl_UniCharToLower(*ustring1)==u2lc)) && - (length2==1 || strCmpFn(ustring1, ustring2, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; + if (objc == 4) { + int length; + const char *string = TclGetStringFromObj(objv[1], &length); - Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); - } - } - } + if ((length > 1) && + strncmp(string, "-nocase", (size_t) length) == 0) { + nocase = TCL_MATCH_NOCASE; } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringRangeCmd -- + * + * This procedure is invoked to process the "string range" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - /* - * Precompute pointers to the unicode string and length. This - * saves us repeated function calls later, significantly speeding - * up the algorithm. We only need the lowercase first char in the - * nocase case. - */ +static int +StringRangeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length, first, last; - mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) - * sizeof(Tcl_UniChar *)); - mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); - if (nocase) { - u2lc = (Tcl_UniChar *) - ckalloc((mapElemc) * sizeof(Tcl_UniChar)); - } - for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], - &(mapLens[index])); - if (nocase && ((index % 2) == 0)) { - u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); - } - } - for (p = ustring1; ustring1 < end; ustring1++) { - for (index = 0; index < mapElemc; index += 2) { - /* - * Get the key string to match on. - */ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string first last"); + return TCL_ERROR; + } - ustring2 = mapStrings[index]; - length2 = mapLens[index]; - if ((length2 > 0) && ((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc[index/2]))) && - /* restrict max compare length */ - ((end - ustring1) >= length2) && - ((length2 == 1) || strCmpFn(ustring2, ustring1, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - /* - * Put the skipped chars onto the result first. - */ + /* + * Get the length in actual characters; Then reduce it by one because + * 'end' refers to the last character, not one past it. + */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } + length = Tcl_GetCharLength(objv[1]) - 1; - /* - * Adjust len to be full length of matched string. - */ + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { + return TCL_ERROR; + } - ustring1 = p - 1; + if (first < 0) { + first = 0; + } + if (last >= length) { + last = length; + } + if (last >= first) { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringReptCmd -- + * + * This procedure is invoked to process the "string repeat" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - /* - * Append the map value to the unicode string. - */ +static int +StringReptCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1; + char *string2; + int count, index, length1, length2; + Tcl_Obj *resultPtr; - Tcl_AppendUnicodeToObj(resultPtr, - mapStrings[index+1], mapLens[index+1]); - break; - } - } - } - ckfree((char *) mapStrings); - ckfree((char *) mapLens); - if (nocase) { - ckfree((char *) u2lc); - } - } - if (p != ustring1) { - /* - * Put the rest of the unmapped chars onto result. - */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string count"); + return TCL_ERROR; + } + + if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Check for cases that allow us to skip copying stuff. + */ + + if (count == 1) { + Tcl_SetObjResult(interp, objv[1]); + goto done; + } else if (count < 1) { + goto done; + } + string1 = TclGetStringFromObj(objv[1], &length1); + if (length1 <= 0) { + goto done; + } + + /* + * Only build up a string that has data. Instead of building it up with + * repeated appends, we just allocate the necessary space once and copy + * the string value in. + * + * We have to worry about overflow [Bugs 714106, 2561746]. + * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. + * We need to keep 2 <= length2 <= INT_MAX. + */ + + if (count > INT_MAX/length1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "result exceeds max size for a Tcl value (%d bytes)", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + length2 = length1 * count; + + /* + * Include space for the NUL. + */ + + string2 = attemptckalloc((unsigned) length2 + 1); + if (string2 == NULL) { + /* + * Alloc failed. Note that in this case we try to do an error message + * since this is a case that's most likely when the alloc is large and + * that's easy to do with this API. Note that if we fail allocating a + * short string, this will likely keel over too (and fatally). + */ + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "string size overflow, out of memory allocating %u bytes", + length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + return TCL_ERROR; + } + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, (size_t) length1); + } + string2[length2] = '\0'; + + /* + * We have to directly assign this instead of using Tcl_SetStringObj (and + * indirectly TclInitStringRep) because that makes another copy of the + * data. + */ + + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); + + done: + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringRplcCmd -- + * + * This procedure is invoked to process the "string replace" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringRplcCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar *ustring; + int first, last, length; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); + return TCL_ERROR; + } + + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length--; + + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ + return TCL_ERROR; + } - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + if ((last < first) || (last < 0) || (first > length)) { + Tcl_SetObjResult(interp, objv[1]); + } else { + Tcl_Obj *resultPtr; + + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length--; + + if (first < 0) { + first = 0; } - if (mapWithDict) { - ckfree((char *) mapElemv); + + resultPtr = Tcl_NewUnicodeObj(ustring, first); + if (objc == 5) { + Tcl_AppendObjToObj(resultPtr, objv[4]); } - if (copySource) { - Tcl_DecrRefCount(sourceObj); + if (last < length) { + Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, + length - last); } Tcl_SetObjResult(interp, resultPtr); - break; } - case STR_MATCH: { - Tcl_UniChar *ustring1, *ustring2; - int nocase = 0; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringRevCmd -- + * + * This procedure is invoked to process the "string reverse" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringRevCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); - return TCL_ERROR; + Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringStartCmd -- + * + * This procedure is invoked to process the "string wordstart" Tcl + * command. See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed Tcl UTF + * strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringStartCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar ch; + const char *p, *string; + int cur, index, length, numChars; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string index"); + return TCL_ERROR; + } + + string = TclGetStringFromObj(objv[1], &length); + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + string = TclGetStringFromObj(objv[1], &length); + if (index >= numChars) { + index = numChars - 1; + } + cur = 0; + if (index > 0) { + p = Tcl_UtfAtIndex(string, index); + for (cur = index; cur >= 0; cur--) { + TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; + } + p = Tcl_UtfPrev(p, string); } + if (cur != index) { + cur += 1; + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringEndCmd -- + * + * This procedure is invoked to process the "string wordend" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase", (char *) NULL); - return TCL_ERROR; +static int +StringEndCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_UniChar ch; + const char *p, *end, *string; + int cur, index, length, numChars; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "string index"); + return TCL_ERROR; + } + + string = TclGetStringFromObj(objv[1], &length); + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + string = TclGetStringFromObj(objv[1], &length); + if (index < 0) { + index = 0; + } + if (index < numChars) { + p = Tcl_UtfAtIndex(string, index); + end = string+length; + for (cur = index; p < end; cur++) { + p += TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; } } - ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( - ustring1, length1, ustring2, length2, nocase))); - break; + if (cur == index) { + cur++; + } + } else { + cur = numChars; } - case STR_RANGE: { - int first, last; + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringEqualCmd -- + * + * This procedure is invoked to process the "string equal" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringEqualCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* + * Remember to keep code here in some sync with the byte-compiled versions + * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as + * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). + */ - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string first last"); + const char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; + + if (objc < 3 || objc > 6) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 1; i < objc-2; i++) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + nocase = 1; + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { + if (i+1 >= objc-2) { + goto str_cmp_args; + } + i++; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } + } + + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ + + objv += objc-2; + if ((reqlength == 0) || (objv[0] == objv[1])) { /* - * If we have a ByteArray object, avoid indexing in the Utf string - * since the byte array contains one byte per character. Otherwise, - * use the Unicode string rep to get the range. + * Always match at 0 chars of if it is the same obj. */ - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); - length1--; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); + return TCL_OK; + } + + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ + + string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of String + * type. In benchmark testing this proved the most efficient check + * between the unicode and string comparison operations. + */ + + string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use memcmp() as + * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's + * utf rep). We can use the more efficient TclpUtfNcmp2 if we are + * case-sensitive and no specific length was requested. + */ + + string1 = (char *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + if ((reqlength < 0) && (length1 != length2)) { + match = 1; /* This will be reversed below. */ + } else { + length = (length1 < length2) ? length1 : length2; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { /* - * Get the length in actual characters. + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. */ - string1 = NULL; - length1 = Tcl_GetCharLength(objv[2]) - 1; + reqlength = length + 1; } - if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || - TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { - return TCL_ERROR; + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; } + } - if (first < 0) { - first = 0; - } - if (last >= length1) { - last = length1; - } - if (last >= first) { - if (string1 != NULL) { - int numBytes = last - first + 1; - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) &string1[first], numBytes)); - } else { - Tcl_SetObjResult(interp, - Tcl_GetRange(objv[2], first, last)); - } - } - break; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringCmpCmd -- + * + * This procedure is invoked to process the "string compare" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringCmpCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + /* + * Remember to keep code here in some sync with the byte-compiled versions + * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as + * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). + */ + + const char *string1, *string2; + int length1, length2, i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); + strCmpFn_t strCmpFn; + + if (objc < 3 || objc > 6) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; } - case STR_REPEAT: { - int count; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string count"); + for (i = 1; i < objc-2; i++) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + nocase = 1; + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { + if (i+1 >= objc-2) { + goto str_cmp_args; + } + i++; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } + } - if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { - return TCL_ERROR; - } + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ - if (count == 1) { - Tcl_SetObjResult(interp, objv[2]); - } else if (count > 1) { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (length1 > 0) { - /* - * Only build up a string that has data. Instead of building - * it up with repeated appends, we just allocate the necessary - * space once and copy the string value in. Check for - * overflow with back-division. [Bug #714106] - */ + objv += objc-2; - Tcl_Obj *resultPtr; - length2 = length1 * count; - if ((length2 / count) != length1) { - char buf[TCL_INTEGER_SPACE+1]; - sprintf(buf, "%d", INT_MAX); - Tcl_AppendResult(interp, - "string size overflow, must be less than ", - buf, (char *) NULL); - return TCL_ERROR; - } + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ - /* - * Include space for the NULL. - */ + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + return TCL_OK; + } - string2 = (char *) ckalloc((size_t) length2+1); - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, - (size_t) length1); - } - string2[length2] = '\0'; + if (!nocase && TclIsPureByteArray(objv[0]) && + TclIsPureByteArray(objv[1])) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ - /* - * We have to directly assign this instead of using - * Tcl_SetStringObj (and indirectly TclInitStringRep) because - * that makes another copy of the data. - */ + string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of String + * type. In benchmark testing this proved the most efficient check + * between the unicode and string comparison operations. + */ - TclNewObj(resultPtr); - resultPtr->bytes = string2; - resultPtr->length = length2; - Tcl_SetObjResult(interp, resultPtr); - } + string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use memcmp() as + * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's + * utf rep). We can use the more efficient TclpUtfNcmp2 if we are + * case-sensitive and no specific length was requested. + */ + + string1 = (char *) TclGetStringFromObj(objv[0], &length1); + string2 = (char *) TclGetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } - break; } - case STR_REPLACE: { - Tcl_UniChar *ustring1; - int first, last; - if (objc < 5 || objc > 6) { - Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); - return TCL_ERROR; - } + length = (length1 < length2) ? length1 : length2; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by setting it to + * length + 1 so we correct the match var. + */ - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - length1--; + reqlength = length + 1; + } - if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || - TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { - return TCL_ERROR; - } + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } - if ((last < first) || (last < 0) || (first > length1)) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_Obj *resultPtr; - if (first < 0) { - first = 0; - } + Tcl_SetObjResult(interp, + Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringBytesCmd -- + * + * This procedure is invoked to process the "string bytelength" Tcl + * command. See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed Tcl UTF + * strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - resultPtr = Tcl_NewUnicodeObj(ustring1, first); - if (objc == 6) { - Tcl_AppendObjToObj(resultPtr, objv[5]); - } - if (last < length1) { - Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, - length1 - last); - } - Tcl_SetObjResult(interp, resultPtr); - } - break; +static int +StringBytesCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; } - case STR_TOLOWER: - case STR_TOUPPER: - case STR_TOTITLE: - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); - return TCL_ERROR; - } - string1 = Tcl_GetStringFromObj(objv[2], &length1); + (void) TclGetStringFromObj(objv[1], &length); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringLenCmd -- + * + * This procedure is invoked to process the "string length" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if (objc == 3) { - Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); - if ((enum options) index == STR_TOLOWER) { - length1 = Tcl_UtfToLower(TclGetString(resultPtr)); - } else if ((enum options) index == STR_TOUPPER) { - length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); - } else { - length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); - } - Tcl_SetObjLength(resultPtr, length1); - Tcl_SetObjResult(interp, resultPtr); - } else { - int first, last; - CONST char *start, *end; - Tcl_Obj *resultPtr; +static int +StringLenCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } - length1 = Tcl_NumUtfChars(string1, length1) - 1; - if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK){ - return TCL_ERROR; - } - if (first < 0) { - first = 0; - } - last = first; + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringLowerCmd -- + * + * This procedure is invoked to process the "string tolower" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ - if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } +static int +StringLowerCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2; + const char *string1; + char *string2; - if (last >= length1) { - last = length1; - } - if (last < first) { - Tcl_SetObjResult(interp, objv[2]); - break; - } + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; + } - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); - length2 = end-start; - string2 = ckalloc((size_t) length2+1); - memcpy(string2, start, (size_t) length2); - string2[length2] = '\0'; + string1 = TclGetStringFromObj(objv[1], &length1); - if ((enum options) index == STR_TOLOWER) { - length2 = Tcl_UtfToLower(string2); - } else if ((enum options) index == STR_TOUPPER) { - length2 = Tcl_UtfToUpper(string2); - } else { - length2 = Tcl_UtfToTitle(string2); - } + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToLower(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; - resultPtr = Tcl_NewStringObj(string1, start - string1); - Tcl_AppendToObj(resultPtr, string2, length2); - Tcl_AppendToObj(resultPtr, end, -1); - Tcl_SetObjResult(interp, resultPtr); - ckfree(string2); + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { + return TCL_ERROR; } - break; + if (first < 0) { + first = 0; + } + last = first; - case STR_TRIMLEFT: - left = 1; - right = 0; - goto dotrim; - case STR_TRIMRIGHT: - left = 0; - right = 1; - goto dotrim; - case STR_TRIM: { - Tcl_UniChar ch, trim; - register CONST char *p, *end; - char *check, *checkEnd; - int offset; - - left = 1; - right = 1; - - dotrim: - if (objc == 4) { - string2 = Tcl_GetStringFromObj(objv[3], &length2); - } else if (objc == 3) { - string2 = " \t\n\r"; - length2 = strlen(string2); - } else { - Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { return TCL_ERROR; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - checkEnd = string2 + length2; - if (left) { - end = string1 + length1; - /* - * The outer loop iterates over the string. The inner loop - * iterates over the trim characters. The loops terminate as soon - * as a non-trim character is discovered and string1 is left - * pointing at the first non-trim character. - */ + if (last >= length1) { + last = length1; + } + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - } - if (right) { - end = string1; + length2 = Tcl_UtfToLower(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); - /* - * The outer loop iterates over the string. The inner loop - * iterates over the trim characters. The loops terminate as soon - * as a non-trim character is discovered and length1 marks the - * last non-trim character. - */ + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); + } - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } - } - } - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); - break; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringUpperCmd -- + * + * This procedure is invoked to process the "string toupper" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringUpperCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2; + const char *string1; + char *string2; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; } - case STR_WORDEND: { - int cur; - Tcl_UniChar ch; - CONST char *p, *end; - int numChars; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); + string1 = TclGetStringFromObj(objv[1], &length1); + + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; + + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } + if (first < 0) { + first = 0; + } + last = first; - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { return TCL_ERROR; } - if (index < 0) { - index = 0; + + if (last >= length1) { + last = length1; } - if (index < numChars) { - p = Tcl_UtfAtIndex(string1, index); - end = string1+length1; - for (cur = index; p < end; cur++) { - p += TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; - } - } - if (cur == index) { - cur++; - } - } else { - cur = numChars; + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; + + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); + + length2 = Tcl_UtfToUpper(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); + + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTitleCmd -- + * + * This procedure is invoked to process the "string totitle" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringTitleCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length1, length2; + const char *string1; + char *string2; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); + return TCL_ERROR; } - case STR_WORDSTART: { - int cur; - Tcl_UniChar ch; - CONST char *p; - int numChars; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); + string1 = TclGetStringFromObj(objv[1], &length1); + + if (objc == 2) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + + length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { + int first, last; + const char *start, *end; + Tcl_Obj *resultPtr; + + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } + if (first < 0) { + first = 0; + } + last = first; - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, + &last) != TCL_OK)) { return TCL_ERROR; } - if (index >= numChars) { - index = numChars - 1; + + if (last >= length1) { + last = length1; } - cur = 0; - if (index > 0) { - p = Tcl_UtfAtIndex(string1, index); - for (cur = index; cur >= 0; cur--) { - TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; - } - p = Tcl_UtfPrev(p, string1); - } - if (cur != index) { - cur += 1; - } + if (last < first) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; + + string1 = TclGetStringFromObj(objv[1], &length1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + resultPtr = Tcl_NewStringObj(string1, end - string1); + string2 = TclGetString(resultPtr) + (start - string1); + + length2 = Tcl_UtfToTitle(string2); + Tcl_SetObjLength(resultPtr, length2 + (start - string1)); + + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTrimCmd -- + * + * This procedure is invoked to process the "string trim" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringTrimCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1, *string2; + int triml, trimr, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; + } + string1 = TclGetStringFromObj(objv[1], &length1); + + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); + + Tcl_SetObjResult(interp, + Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTrimLCmd -- + * + * This procedure is invoked to process the "string trimleft" Tcl + * command. See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed Tcl UTF + * strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringTrimLCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1, *string2; + int trim, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; } + string1 = TclGetStringFromObj(objv[1], &length1); + + trim = TclTrimLeft(string1, length1, string2, length2); + + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1+trim, length1-trim)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * StringTrimRCmd -- + * + * This procedure is invoked to process the "string trimright" Tcl + * command. See the user documentation for details on what it does. Note + * that this command only functions correctly on properly formed Tcl UTF + * strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringTrimRCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *string1, *string2; + int trim, length1, length2; + + if (objc == 3) { + string2 = TclGetStringFromObj(objv[2], &length2); + } else if (objc == 2) { + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); + } else { + Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); + return TCL_ERROR; } + string1 = TclGetStringFromObj(objv[1], &length1); + + trim = TclTrimRight(string1, length1, string2, length2); + + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1-trim)); return TCL_OK; } /* *---------------------------------------------------------------------- * + * TclInitStringCmd -- + * + * This procedure creates the "string" Tcl command. See the user + * documentation for details on what it does. Note that this command only + * functions correctly on properly formed Tcl UTF strings. + * + * Also note that the primary methods here (equal, compare, match, ...) + * have bytecode equivalents. You will find the code for those in + * tclExecute.c. The code here will only be used in the non-bc case (like + * in an 'eval'). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitStringCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap stringImplMap[] = { + {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, + {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, + {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, + {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, + {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, + {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, + {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, + {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, + {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, + {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, + {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + + return TclMakeEnsemble(interp, "string", stringImplMap); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_SubstObjCmd -- * - * This procedure is invoked to process the "subst" Tcl command. See the - * user documentation for details on what it does. This command relies - * on Tcl_SubstObj() for its implementation. + * This procedure is invoked to process the "subst" Tcl command. See the + * user documentation for details on what it does. This command relies on + * Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. @@ -2481,30 +3373,25 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_SubstObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +TclSubstOptions( + Tcl_Interp *interp, + int numOpts, + Tcl_Obj *const opts[], + int *flagPtr) { - static CONST char *substOptions[] = { - "-nobackslashes", "-nocommands", "-novariables", (char *) NULL + static const char *const substOptions[] = { + "-nobackslashes", "-nocommands", "-novariables", NULL }; - enum substOptions { - SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS + enum { + SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - Tcl_Obj *resultPtr; - int optionIndex, flags, i; + int i, flags = TCL_SUBST_ALL; - /* - * Parse command-line options. - */ + for (i = 0; i < numOpts; i++) { + int optionIndex; - flags = TCL_SUBST_ALL; - for (i = 1; i < (objc-1); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -2522,23 +3409,39 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - if (i != (objc-1)) { + *flagPtr = flags; + return TCL_OK; +} + +int +Tcl_SubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv); +} + +int +TclNRSubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int flags; + + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - /* - * Perform the substitution. - */ - - resultPtr = Tcl_SubstObj(interp, objv[i], flags); - - if (resultPtr == NULL) { + if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return Tcl_NRSubstObj(interp, objv[objc-1], flags); } /* @@ -2558,26 +3461,41 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_SwitchObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_SwitchObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; - char *pattern; + return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv); +} +int +TclNRSwitchObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; + int noCase, patternLength; + const char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; - Tcl_Obj *CONST *savedObjv = objv; + Tcl_Obj *const *savedObjv = objv; Tcl_RegExp regExpr = NULL; + Interp *iPtr = (Interp *) interp; + int pc = 0; + int bidx = 0; /* Index of body argument. */ + Tcl_Obj *blist = NULL; /* List obj which is the body */ + CmdFrame *ctxPtr; /* Copy of the topmost cmdframe, to allow us + * to mess with the line information */ /* * If you add options that make -e and -g not unique prefixes of -exact or * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ - static CONST char *options[] = { + static const char *const options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; @@ -2585,7 +3503,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; - typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *)); + typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; @@ -2594,7 +3512,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) matchVarObj = NULL; numMatchesSaved = 0; noCase = 0; - for (i = 1; i < objc; i++) { + for (i = 1; i < objc-2; i++) { if (TclGetString(objv[i])[0] != '-') { break; } @@ -2602,85 +3520,115 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) &index) != TCL_OK) { return TCL_ERROR; } - if (index == OPT_LAST) { + switch ((enum options) index) { + /* + * General options. + */ + + case OPT_LAST: i++; + goto finishedOptions; + case OPT_NOCASE: + strCmpFn = TclUtfCasecmp; + noCase = 1; break; - } - /* - * Check for TIP#75 options specifying the variables to write regexp - * information into. - */ + /* + * Handle the different switch mode options. + */ + + default: + if (foundmode) { + /* + * Mode already set via -exact, -glob, or -regexp. + */ + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": %s option already found", + TclGetString(objv[i]), options[mode])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); + return TCL_ERROR; + } + foundmode = 1; + mode = index; + break; - if (index == OPT_INDEXV) { + /* + * Check for TIP#75 options specifying the variables to write + * regexp information into. + */ + + case OPT_INDEXV: i++; - if (i == objc) { - Tcl_AppendResult(interp, - "missing variable name argument to -indexvar option", - (char *) NULL); + if (i >= objc-2) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; numMatchesSaved = -1; - } else if (index == OPT_MATCHV) { + break; + case OPT_MATCHV: i++; - if (i == objc) { - Tcl_AppendResult(interp, - "missing variable name argument to -matchvar option", - (char *) NULL); + if (i >= objc-2) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; numMatchesSaved = -1; - } else if (index == OPT_NOCASE) { - strCmpFn = strcasecmp; - noCase = 1; - } else { - if (foundmode) { - /* - * Mode already set via -exact, -glob, or -regexp. - */ - - Tcl_AppendResult(interp, "bad option \"", - TclGetString(objv[i]), "\": ", options[mode], - " option already found", (char *) NULL); - return TCL_ERROR; - } - foundmode = 1; - mode = index; + break; } } + finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? string pattern body ... ?default body?"); + "?-switch ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-indexvar option requires -regexp option", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-matchvar option requires -regexp option", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } stringObj = objv[i]; objc -= i + 1; objv += i + 1; + bidx = i + 1; /* First after the match string. */ /* * If all of the pattern/command pairs are lumped into a single argument, * split them out again. + * + * TIP #280: Determine the lines the words in the list start at, based on + * the same data for the list word itself. The cmdFramePtr line + * information is manipulated directly. */ splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + blist = objv[0]; + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } @@ -2690,7 +3638,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?switches? string {pattern body ... ?default body?}"); + "?-switch ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } objv = listv; @@ -2704,7 +3652,10 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (objc % 2) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra switch pattern with no body", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -2717,10 +3668,12 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { - Tcl_AppendResult(interp, ", this may be due to a ", - "comment incorrectly placed outside of a ", - "switch body - see the \"switch\" ", - "documentation", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ", this may be due to a comment incorrectly" + " placed outside of a switch body - see the" + " \"switch\" documentation", -1); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -2730,14 +3683,16 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } /* - * Complain if the last body is a continuation. Note that this check + * Complain if the last body is a continuation. Note that this check * assumes that the list is non-empty! */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "no body specified for pattern \"", - TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no body specified for pattern \"%s\"", + TclGetString(objv[objc-2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -2746,7 +3701,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) * See if the pattern matches the string. */ - pattern = TclGetString(objv[i]); + pattern = TclGetStringFromObj(objv[i], &patternLength); if ((i == objc - 2) && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { @@ -2754,7 +3709,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) /* * If either indexVarObj or matchVarObj are non-NULL, we're in - * REGEXP mode but have reached the default clause anyway. TIP#75 + * REGEXP mode but have reached the default clause anyway. TIP#75 * specifies that we set the variables to empty lists (== empty * objects) in that case. */ @@ -2763,7 +3718,6 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) TclNewObj(emptyObj); if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(emptyObj); return TCL_ERROR; } } @@ -2773,42 +3727,39 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj, TCL_LEAVE_ERR_MSG) == NULL) { - if (indexVarObj == NULL) { - Tcl_DecrRefCount(emptyObj); - } return TCL_ERROR; } } goto matchFound; - } else { - switch (mode) { - case OPT_EXACT: - if (strCmpFn(TclGetString(stringObj), pattern) == 0) { - goto matchFound; - } - break; - case OPT_GLOB: - if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, - noCase)) { - goto matchFound; - } - break; - case OPT_REGEXP: - regExpr = Tcl_GetRegExpFromObj(interp, objv[i], - TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); - if (regExpr == NULL) { + } + + switch (mode) { + case OPT_EXACT: + if (strCmpFn(TclGetString(stringObj), pattern) == 0) { + goto matchFound; + } + break; + case OPT_GLOB: + if (Tcl_StringCaseMatch(TclGetString(stringObj),pattern,noCase)) { + goto matchFound; + } + break; + case OPT_REGEXP: + regExpr = Tcl_GetRegExpFromObj(interp, objv[i], + TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); + if (regExpr == NULL) { + return TCL_ERROR; + } else { + int matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0, + numMatchesSaved, 0); + + if (matched < 0) { return TCL_ERROR; - } else { - int matched = Tcl_RegExpExecObj(interp, regExpr, - stringObj, 0, numMatchesSaved, 0); - if (matched < 0) { - return TCL_ERROR; - } else if (matched) { - goto matchFoundRegexp; - } + } else if (matched) { + goto matchFoundRegexp; } - break; } + break; } } return TCL_OK; @@ -2838,11 +3789,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; - rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); + if (info.matches[j].end > 0) { + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); + } else { + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + } + /* * Never fails; the object is always clean at this point. */ + Tcl_ListObjAppendElement(NULL, indicesObj, Tcl_NewListObj(2, rangeObjAry)); } @@ -2852,9 +3809,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) substringObj = Tcl_GetRange(stringObj, info.matches[j].start, info.matches[j].end-1); + /* * Never fails; the object is always clean at this point. */ + Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); } } @@ -2862,13 +3821,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (indexVarObj != NULL) { if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(indicesObj); - /* - * Careful! Check to see if we have allocated the list of + * Careful! Check to see if we have allocated the list of * matched strings; if so (but there was an error assigning * the indices list) we have a potential memory leak because - * the match list has not been written to a variable. Except + * the match list has not been written to a variable. Except * that we'll clean that up right now. */ @@ -2881,8 +3838,6 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (matchVarObj != NULL) { if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(matchesObj); - /* * Unlike above, if indicesObj is non-NULL at this point, it * will have been written to a variable already and will hence @@ -2900,12 +3855,65 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) */ matchFound: + ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + *ctxPtr = *iPtr->cmdFramePtr; + + if (splitObjs) { + /* + * We have to perform the GetSrc and other type dependent handling of + * the frame here because we are munging with the line numbers, + * something the other commands like if, etc. are not doing. Them are + * fine with simply passing the CmdFrame through and having the + * special handling done in 'info frame', or the bc compiler + */ + + if (ctxPtr->type == TCL_LOCATION_BC) { + /* + * Type BC => ctxPtr->data.eval.path is not used. + * ctxPtr->data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + + /* + * The line information in the cmdFrame is now a copy we do not + * own. + */ + } + + if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { + int bline = ctxPtr->line[bidx]; + + ctxPtr->line = ckalloc(objc * sizeof(int)); + ctxPtr->nline = objc; + TclListLines(blist, bline, objc, ctxPtr->line, objv); + } else { + /* + * This is either a dynamic code word, when all elements are + * relative to themselves, or something else less expected and + * where we have no information. The result is the same in both + * cases; tell the code to come that it doesn't know where it is, + * which triggers reversion to the old behavior. + */ + + int k; + + ctxPtr->line = ckalloc(objc * sizeof(int)); + ctxPtr->nline = objc; + for (k=0; k < objc; k++) { + ctxPtr->line[k] = -1; + } + } + } + for (j = i + 1; ; j += 2) { if (j >= objc) { /* * This shouldn't happen since we've checked that the last body is * not a continuation... */ + Tcl_Panic("fall-out when searching for body to match pattern"); } if (strcmp(TclGetString(objv[j]), "-") != 0) { @@ -2913,35 +3921,131 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } } - result = Tcl_EvalObjEx(interp, objv[j], 0); + /* + * TIP #280: Make invoking context available to switch branch. + */ + + Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, + INT2PTR(pc), (ClientData) pattern); + return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); +} + +static int +SwitchPostProc( + ClientData data[], /* Data passed from Tcl_NRAddCallback above */ + Tcl_Interp *interp, /* Tcl interpreter */ + int result) /* Result to return*/ +{ + /* Unpack the preserved data */ + + int splitObjs = PTR2INT(data[0]); + CmdFrame *ctxPtr = data[1]; + int pc = PTR2INT(data[2]); + const char *pattern = data[3]; + int patternLength = strlen(pattern); + + /* + * Clean up TIP 280 context information + */ + + if (splitObjs) { + ckfree(ctxPtr->line); + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * Death of SrcInfo reference. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + } + } /* * Generate an error message if necessary. */ if (result == TCL_ERROR) { - Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); - Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); - Tcl_IncrRefCount(msg); - Tcl_IncrRefCount(errorLine); - TclAppendLimitedToObj(msg, pattern, -1, 50, ""); - Tcl_AppendToObj(msg,"\" arm line ", -1); - Tcl_AppendObjToObj(msg, errorLine); - Tcl_DecrRefCount(errorLine); - Tcl_AppendToObj(msg,")", -1); - TclAppendObjToErrorInfo(interp, msg); - Tcl_DecrRefCount(msg); + int limit = 50; + int overflow = (patternLength > limit); + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.*s%s\" arm line %d)", + (overflow ? limit : patternLength), pattern, + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } + TclStackFree(interp, ctxPtr); return result; } /* *---------------------------------------------------------------------- * + * Tcl_ThrowObjCmd -- + * + * This procedure is invoked to process the "throw" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ThrowObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *options; + int len; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type message"); + return TCL_ERROR; + } + + /* + * The type must be a list of at least length 1. + */ + + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + return TCL_ERROR; + } else if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "type must be non-empty list", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); + return TCL_ERROR; + } + + /* + * Now prepare the result options dictionary. We use the list API as it is + * slightly more convenient. + */ + + TclNewLiteralStringObj(options, "-code error -level 0 -errorcode"); + Tcl_ListObjAppendElement(NULL, options, objv[1]); + + /* + * We're ready to go. Fire things into the low-level result machinery. + */ + + Tcl_SetObjResult(interp, objv[2]); + return Tcl_SetReturnOptions(interp, options); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl - * command. See the user documentation for details on what it does. + * command. See the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -2952,25 +4056,28 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_TimeObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_TimeObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { register Tcl_Obj *objPtr; Tcl_Obj *objs[4]; register int i, result; int count; double totalMicroSec; +#ifndef TCL_WIDE_CLICKS Tcl_Time start, stop; +#else + Tcl_WideInt start, stop; +#endif if (objc == 2) { count = 1; } else if (objc == 3) { - result = Tcl_GetIntFromObj(interp, objv[2], &count); + result = TclGetIntFromObj(interp, objv[2], &count); if (result != TCL_OK) { return result; } @@ -2981,17 +4088,25 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) objPtr = objv[1]; i = count; +#ifndef TCL_WIDE_CLICKS Tcl_GetTime(&start); +#else + start = TclpGetWideClicks(); +#endif while (i-- > 0) { result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } } +#ifndef TCL_WIDE_CLICKS Tcl_GetTime(&stop); - - totalMicroSec = (((double) (stop.sec - start.sec))*1.0e6 - + (stop.usec - start.usec)); + totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6 + + (stop.usec - start.usec); +#else + stop = TclpGetWideClicks(); + totalMicroSec = ((double) TclpWideClicksToNanoseconds(stop - start))/1.0e3; +#endif if (count <= 1) { /* @@ -3005,12 +4120,12 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* * Construct the result as a list because many programs have always parsed - * at such (extracting the first element, typically). + * as such (extracting the first element, typically). */ - objs[1] = Tcl_NewStringObj("microseconds", -1); - objs[2] = Tcl_NewStringObj("per", -1); - objs[3] = Tcl_NewStringObj("iteration", -1); + TclNewLiteralStringObj(objs[1], "microseconds"); + TclNewLiteralStringObj(objs[2], "per"); + TclNewLiteralStringObj(objs[3], "iteration"); Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); return TCL_OK; @@ -3019,66 +4134,690 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * + * Tcl_TryObjCmd, TclNRTryObjCmd -- + * + * This procedure is invoked to process the "try" Tcl command. See the + * user documentation (or TIP #329) for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TryObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv); +} + +int +TclNRTryObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL; + int i, bodyShared, haveHandlers, dummy, code; + static const char *const handlerNames[] = { + "finally", "on", "trap", NULL + }; + enum Handlers { + TryFinally, TryOn, TryTrap + }; + + /* + * Parse the arguments. The handlers are passed to subsequent callbacks as + * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix, + * bindVariables, script), and the finally script is just passed as it is. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "body ?handler ...? ?finally script?"); + return TCL_ERROR; + } + bodyObj = objv[1]; + handlersObj = Tcl_NewObj(); + bodyShared = 0; + haveHandlers = 0; + for (i=2 ; i<objc ; i++) { + int type; + Tcl_Obj *info[5]; + + if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", + 0, &type) != TCL_OK) { + Tcl_DecrRefCount(handlersObj); + return TCL_ERROR; + } + switch ((enum Handlers) type) { + case TryFinally: /* finally script */ + if (i < objc-2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "finally clause must be last", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "NONTERMINAL", NULL); + return TCL_ERROR; + } else if (i == objc-1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to finally clause: must be" + " \"... finally script\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); + return TCL_ERROR; + } + finallyObj = objv[++i]; + break; + + case TryOn: /* on code variableList script */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to on clause: must be \"... on code" + " variableList script\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); + return TCL_ERROR; + } + if (TclGetCompletionCodeFromObj(interp, objv[i+1], + &code) != TCL_OK) { + Tcl_DecrRefCount(handlersObj); + return TCL_ERROR; + } + info[2] = NULL; + goto commonHandler; + + case TryTrap: /* trap pattern variableList script */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to trap clause: " + "must be \"... trap pattern variableList script\"", + -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); + return TCL_ERROR; + } + code = 1; + if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad prefix '%s': must be a list", + Tcl_GetString(objv[i+1]))); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); + return TCL_ERROR; + } + info[2] = objv[i+1]; + + commonHandler: + if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + Tcl_DecrRefCount(handlersObj); + return TCL_ERROR; + } + + info[0] = objv[i]; /* type */ + TclNewIntObj(info[1], code); /* returnCode */ + if (info[2] == NULL) { /* errorCodePrefix */ + TclNewObj(info[2]); + } + info[3] = objv[i+2]; /* bindVariables */ + info[4] = objv[i+3]; /* script */ + + bodyShared = !strcmp(TclGetString(objv[i+3]), "-"); + Tcl_ListObjAppendElement(NULL, handlersObj, + Tcl_NewListObj(5, info)); + haveHandlers = 1; + i += 3; + break; + } + } + if (bodyShared) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "last non-finally clause must not have a body of \"-\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); + return TCL_ERROR; + } + if (!haveHandlers) { + Tcl_DecrRefCount(handlersObj); + handlersObj = NULL; + } + + /* + * Execute the body. + */ + + Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, + (ClientData)objv, INT2PTR(objc)); + return TclNREvalObjEx(interp, bodyObj, 0, + ((Interp *) interp)->cmdFramePtr, 1); +} + +/* + *---------------------------------------------------------------------- + * + * During -- + * + * This helper function patches together the updates to the interpreter's + * return options that are needed when things fail during the processing + * of a handler or finally script for the [try] command. + * + * Returns: + * The new option dictionary. + * + *---------------------------------------------------------------------- + */ + +static inline Tcl_Obj * +During( + Tcl_Interp *interp, + int resultCode, /* The result code from the just-evaluated + * script. */ + Tcl_Obj *oldOptions, /* The old option dictionary. */ + Tcl_Obj *errorInfo) /* An object to append to the errorinfo and + * release, or NULL if nothing is to be added. + * Designed to be used with Tcl_ObjPrintf. */ +{ + Tcl_Obj *during, *options; + + if (errorInfo != NULL) { + Tcl_AppendObjToErrorInfo(interp, errorInfo); + } + options = Tcl_GetReturnOptions(interp, resultCode); + TclNewLiteralStringObj(during, "-during"); + Tcl_IncrRefCount(during); + Tcl_DictObjPut(interp, options, during, oldOptions); + Tcl_DecrRefCount(during); + Tcl_IncrRefCount(options); + Tcl_DecrRefCount(oldOptions); + return options; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostBody -- + * + * Callback to handle the outcome of the execution of the body of a 'try' + * command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostBody( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv; + int i, dummy, code, objc; + int numHandlers = 0; + + handlersObj = data[0]; + finallyObj = data[1]; + objv = data[2]; + objc = PTR2INT(data[3]); + + cmdObj = objv[0]; + + /* + * Check for limits/rewinding, which override normal trapping behaviour. + */ + + if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body line %d)", TclGetString(cmdObj), + Tcl_GetErrorLine(interp))); + if (handlersObj != NULL) { + Tcl_DecrRefCount(handlersObj); + } + return TCL_ERROR; + } + + /* + * Basic processing of the outcome of the script, including adding of + * errorinfo trace. + */ + + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body line %d)", TclGetString(cmdObj), + Tcl_GetErrorLine(interp))); + } + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + Tcl_ResetResult(interp); + + /* + * Handle the results. + */ + + if (handlersObj != NULL) { + int found = 0; + Tcl_Obj **handlers, **info; + + Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + for (i=0 ; i<numHandlers ; i++) { + Tcl_Obj *handlerBodyObj; + + Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info); + if (!found) { + Tcl_GetIntFromObj(NULL, info[1], &code); + if (code != result) { + continue; + } + + /* + * When processing an error, we must also perform list-prefix + * matching of the errorcode list. However, if this was an + * 'on' handler, the list that we are matching against will be + * empty. + */ + + if (code == TCL_ERROR) { + Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2; + int len1, len2, j; + + TclNewLiteralStringObj(errorCodeName, "-errorcode"); + Tcl_DictObjGet(NULL, options, errorCodeName, &errcode); + Tcl_DecrRefCount(errorCodeName); + Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1); + if (Tcl_ListObjGetElements(NULL, errcode, &len2, + &bits2) != TCL_OK) { + continue; + } + if (len2 < len1) { + continue; + } + for (j=0 ; j<len1 ; j++) { + if (strcmp(TclGetString(bits1[j]), + TclGetString(bits2[j])) != 0) { + /* + * Really want 'continue outerloop;', but C does + * not give us that. + */ + + goto didNotMatch; + } + } + } + + found = 1; + } + + /* + * Now we need to scan forward over "-" bodies. Note that we've + * already checked that the last body is not a "-", so this search + * will terminate successfully. + */ + + if (!strcmp(TclGetString(info[4]), "-")) { + continue; + } + + /* + * Bind the variables. We already know this is a list of variable + * names, but it might be empty. + */ + + Tcl_ResetResult(interp); + result = TCL_ERROR; + Tcl_ListObjLength(NULL, info[3], &dummy); + if (dummy > 0) { + Tcl_Obj *varName; + + Tcl_ListObjIndex(NULL, info[3], 0, &varName); + if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(resultObj); + goto handlerFailed; + } + Tcl_DecrRefCount(resultObj); + if (dummy > 1) { + Tcl_ListObjIndex(NULL, info[3], 1, &varName); + if (Tcl_ObjSetVar2(interp, varName, NULL, options, + TCL_LEAVE_ERR_MSG) == NULL) { + goto handlerFailed; + } + } + } else { + /* + * Dispose of the result to prevent a memleak. [Bug 2910044] + */ + + Tcl_DecrRefCount(resultObj); + } + + /* + * Evaluate the handler body and process the outcome. Note that we + * need to keep the kind of handler for debugging purposes, and in + * any case anything we want from info[] must be extracted right + * now because the info[] array is about to become invalid. There + * is very little refcount handling here however, since we know + * that the objects that we still want to refer to now were input + * arguments to [try] and so are still on the Tcl value stack. + */ + + handlerBodyObj = info[4]; + Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0], + INT2PTR((finallyObj == NULL) ? 0 : objc - 1)); + Tcl_DecrRefCount(handlersObj); + return TclNREvalObjEx(interp, handlerBodyObj, 0, + ((Interp *) interp)->cmdFramePtr, 4*i + 5); + + handlerFailed: + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + options = During(interp, result, options, NULL); + break; + + didNotMatch: + continue; + } + + /* + * No handler matched; get rid of the list of handlers. + */ + + Tcl_DecrRefCount(handlersObj); + } + + /* + * Process the finally clause. + */ + + if (finallyObj != NULL) { + Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, + NULL); + return TclNREvalObjEx(interp, finallyObj, 0, + ((Interp *) interp)->cmdFramePtr, objc - 1); + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostHandler -- + * + * Callback to handle the outcome of the execution of a handler of a + * 'try' command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostHandler( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv; + Tcl_Obj *finallyObj; + int finally; + + objv = data[0]; + options = data[1]; + handlerKindObj = data[2]; + finally = PTR2INT(data[3]); + + cmdObj = objv[0]; + finallyObj = finally ? objv[finally] : 0; + + /* + * Check for limits/rewinding, which override normal trapping behaviour. + */ + + if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... %s\" handler line %d)", + TclGetString(cmdObj), TclGetString(handlerKindObj), + Tcl_GetErrorLine(interp))); + Tcl_DecrRefCount(options); + return TCL_ERROR; + } + + /* + * The handler result completely substitutes for the result of the body. + */ + + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + if (result == TCL_ERROR) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... %s\" handler line %d)", + TclGetString(cmdObj), TclGetString(handlerKindObj), + Tcl_GetErrorLine(interp))); + } else { + Tcl_DecrRefCount(options); + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + } + + /* + * Process the finally clause if it is present. + */ + + if (finallyObj != NULL) { + Interp *iPtr = (Interp *) interp; + + Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, + NULL); + + /* The 'finally' script is always the last argument word. */ + return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr, + finally); + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostFinal -- + * + * Callback to handle the outcome of the execution of the finally script + * of a 'try' command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *options, *cmdObj; + + resultObj = data[0]; + options = data[1]; + cmdObj = data[2]; + + /* + * If the result wasn't OK, we need to adjust the result options. + */ + + if (result != TCL_OK) { + Tcl_DecrRefCount(resultObj); + resultObj = NULL; + if (result == TCL_ERROR) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... finally\" body line %d)", + TclGetString(cmdObj), Tcl_GetErrorLine(interp))); + } else { + Tcl_Obj *origOptions = options; + + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + Tcl_DecrRefCount(origOptions); + } + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_WhileObjCmd -- * - * This procedure is invoked to process the "while" Tcl command. See the - * user documentation for details on what it does. + * This procedure is invoked to process the "while" Tcl command. See the + * user documentation for details on what it does. * * With the bytecode compiler, this procedure is only called when a * command name is computed at runtime, and is "while" or the name to * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ int -Tcl_WhileObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_WhileObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv); +} + +int +TclNRWhileObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, value; + ForIterData *iterPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); - return TCL_ERROR; + return TCL_ERROR; } - while (1) { - result = Tcl_ExprBooleanObj(interp, objv[1], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_EvalObjEx(interp, objv[2], 0); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"while\" body line %d)", - interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); + /* + * We reuse [for]'s callback, passing a NULL for the 'next' script. + */ + + TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr); + iterPtr->cond = objv[1]; + iterPtr->body = objv[2]; + iterPtr->next = NULL; + iterPtr->msg = "\n (\"while\" body line %d)"; + iterPtr->word = 2; + + TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, + NULL, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclListLines -- + * + * ??? + * + * Results: + * Filled in array of line numbers? + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclListLines( + Tcl_Obj *listObj, /* Pointer to obj holding a string with list + * structure. Assumed to be valid. Assumed to + * contain n elements. */ + int line, /* Line the list as a whole starts on. */ + int n, /* #elements in lines */ + int *lines, /* Array of line numbers, to fill. */ + Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of + * derived continuation data */ +{ + const char *listStr = Tcl_GetString(listObj); + const char *listHead = listStr; + int i, length = strlen(listStr); + const char *element = NULL, *next = NULL; + ContLineLoc *clLocPtr = TclContinuationsGet(listObj); + int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); + + for (i = 0; i < n; i++) { + TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); + + TclAdvanceLines(&line, listStr, element); + /* Leading whitespace */ + TclAdvanceContinuations(&line, &clNext, element - listHead); + if (elems && clNext) { + TclContinuationsEnterDerived(elems[i], element-listHead, clNext); + } + lines[i] = line; + length -= (next - listStr); + TclAdvanceLines(&line, element, next); + /* Element */ + listStr = next; + + if (*element == 0) { + /* ASSERT i == n */ + break; + } } - return result; } /* |