diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 3163 |
1 files changed, 919 insertions, 2244 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 1df9dd1..30586b1 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -6,65 +6,21 @@ * contains only commands in the generic core (i.e. those that don't * depend much upon UNIX facilities). * - * Copyright © 1987-1993 The Regents of the University of California. - * Copyright © 1994-1997 Sun Microsystems, Inc. - * Copyright © 1998-2000 Scriptics Corporation. - * Copyright © 2002 ActiveState Corporation. - * Copyright © 2003-2009 Donal K. Fellows. + * 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. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" -#include "tclCompile.h" #include "tclRegexp.h" -#include "tclStringTrim.h" - -static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, - Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static Tcl_NRPostProc SwitchPostProc; -static Tcl_NRPostProc TryPostBody; -static Tcl_NRPostProc TryPostFinal; -static Tcl_NRPostProc TryPostHandler; + static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); -static int StringCmpOpts(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int *nocase, - Tcl_Size *reqlength); - -/* - * 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) */ -; /* *---------------------------------------------------------------------- @@ -85,7 +41,7 @@ const char tclDefaultTrimSet[] = int Tcl_PwdObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -125,22 +81,22 @@ Tcl_PwdObjCmd( int Tcl_RegexpObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size offset, stringLength, matchLength, cflags, eflags; - int i, indices, match, about, all, doinline, numMatchesSaved; + int i, indices, match, about, offset, all, doinline, numMatchesSaved; + int cflags, eflags, stringLength, matchLength; Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; - static const char *const options[] = { + static const char *options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; - enum regexpoptions { + enum options { REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST @@ -149,23 +105,24 @@ Tcl_RegexpObjCmd( indices = 0; about = 0; cflags = TCL_REG_ADVANCED; + eflags = 0; offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { - const char *name; + char *name; int index; name = TclGetString(objv[i]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum regexpoptions) index) { + switch ((enum options) index) { case REGEXP_ALL: all = 1; break; @@ -194,11 +151,11 @@ Tcl_RegexpObjCmd( cflags |= TCL_REG_NLANCH; break; case REGEXP_START: { - Tcl_Size temp; + int temp; if (++i >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[i], TCL_SIZE_MAX - 1, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { @@ -217,7 +174,7 @@ Tcl_RegexpObjCmd( endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? exp string ?matchVar? ?subMatchVar ...?"); + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); goto optionError; } objc -= i; @@ -229,10 +186,8 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "regexp match variables not allowed when using -inline", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", - "MIX_VAR_INLINE", (void *)NULL); + Tcl_AppendResult(interp, "regexp match variables not allowed" + " when using -inline", NULL); goto optionError; } @@ -259,10 +214,10 @@ Tcl_RegexpObjCmd( */ objPtr = objv[1]; - stringLength = TclGetCharLength(objPtr); + stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; @@ -313,7 +268,7 @@ Tcl_RegexpObjCmd( eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (TclGetUniChar(objPtr, offset-1) == '\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -327,7 +282,7 @@ Tcl_RegexpObjCmd( if (match == 0) { /* - * We want to set the value of the interpreter result only when + * We want to set the value of the intepreter result only when * this is the first time through the loop. */ @@ -339,7 +294,7 @@ Tcl_RegexpObjCmd( */ if (!doinline) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } @@ -360,14 +315,14 @@ Tcl_RegexpObjCmd( objc = info.nsubs + 1; if (all <= 1) { - TclNewObj(resultPtr); + resultPtr = Tcl_NewObj(); } } for (i = 0; i < objc; i++) { Tcl_Obj *newPtr; if (indices) { - Tcl_Size start, end; + int start, end; Tcl_Obj *objs[2]; /* @@ -388,21 +343,21 @@ Tcl_RegexpObjCmd( end--; } } else { - start = TCL_INDEX_NONE; - end = TCL_INDEX_NONE; + start = -1; + end = -1; } - TclNewIndexObj(objs[0], start); - TclNewIndexObj(objs[1], end); + objs[0] = Tcl_NewLongObj(start); + objs[1] = Tcl_NewLongObj(end); newPtr = Tcl_NewListObj(2, objs); } else { - if ((i <= info.nsubs) && (info.matches[i].end > 0)) { - newPtr = TclGetRange(objPtr, + if (i <= info.nsubs) { + newPtr = Tcl_GetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { - TclNewObj(newPtr); + newPtr = Tcl_NewObj(); } } if (doinline) { @@ -413,8 +368,11 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_Obj *valuePtr; + valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); + if (valuePtr == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[i]), "\"", NULL); return TCL_ERROR; } } @@ -430,12 +388,11 @@ Tcl_RegexpObjCmd( * 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 indefinitely (because the length of the match is 0, so + * will loop indefinately (because the length of the match is 0, so * offset never changes). */ - matchLength = (info.matches[0].end - info.matches[0].start); - + matchLength = info.matches[0].end - info.matches[0].start; offset += info.matches[0].end; /* @@ -461,7 +418,7 @@ Tcl_RegexpObjCmd( if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } @@ -485,58 +442,53 @@ Tcl_RegexpObjCmd( int Tcl_RegsubObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, cflags, all, match, command; - Tcl_Size idx, wlen, wsublen, offset, numMatches, numParts; - Tcl_Size start, end, subStart, subEnd; + int idx, result, cflags, all, wlen, wsublen, numMatches, offset; + int start, end, subStart, subEnd, match; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static const char *const options[] = { - "-all", "-command", "-expanded", "-line", - "-linestop", "-lineanchor", "-nocase", "-start", + static const char *options[] = { + "-all", "-nocase", "-expanded", + "-line", "-linestop", "-lineanchor", "-start", "--", NULL }; - enum regsubobjoptions { - REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, - REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, + enum options { + REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, + REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; - command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { - const char *name; + char *name; int index; name = TclGetString(objv[idx]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option", + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch ((enum regsubobjoptions) index) { + switch ((enum options) index) { case REGSUB_ALL: all = 1; break; case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; - case REGSUB_COMMAND: - command = 1; - break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; @@ -550,11 +502,11 @@ Tcl_RegsubObjCmd( cflags |= TCL_REG_NLANCH; break; case REGSUB_START: { - Tcl_Size temp; + int temp; if (++idx >= objc) { goto endOfForLoop; } - if (TclGetIntForIndexM(interp, objv[idx], TCL_SIZE_MAX - 1, &temp) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { goto optionError; } if (startIndex) { @@ -571,9 +523,9 @@ Tcl_RegsubObjCmd( } endOfForLoop: - if (objc < idx + 3 || objc > idx + 4) { + if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? exp string subSpec ?varName?"); + "?switches? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -585,16 +537,16 @@ Tcl_RegsubObjCmd( objv += idx; if (startIndex) { - Tcl_Size stringLength = TclGetCharLength(objv[1]); + int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndexM(interp, startIndex, stringLength, &offset); + TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; } } - if (all && (offset == 0) && (command == 0) + if (all && (offset == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* @@ -602,18 +554,17 @@ Tcl_RegsubObjCmd( * slightly modified version of the one pair STR_MAP code. */ - Tcl_Size slen; - int nocase, wsrclc; - int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t); - Tcl_UniChar *p; + int slen, nocase; + int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); + Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); - strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; + strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; - wsrc = TclGetUnicodeFromObj(objv[0], &slen); - wstring = TclGetUnicodeFromObj(objv[1], &wlen); - wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); + 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; @@ -624,11 +575,11 @@ Tcl_RegsubObjCmd( */ if (wstring < wend) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); - TclAppendUnicodeToObj(resultPtr, wstring, 1); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -641,18 +592,18 @@ Tcl_RegsubObjCmd( (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - TclAppendUnicodeToObj(resultPtr, p, wstring - p); + Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -671,28 +622,6 @@ Tcl_RegsubObjCmd( return TCL_ERROR; } - if (command) { - /* - * In command-prefix mode, we require that the third non-option - * argument be a list, so we enforce that here. Afterwards, we fetch - * the RE compilation again in case objv[0] and objv[2] are the same - * object. (If they aren't, that's cheap to do.) - */ - - if (TclListObjLength(interp, objv[2], &numParts) != TCL_OK) { - return TCL_ERROR; - } - if (numParts < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "command prefix must be a list of at least one element", - -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", - "CMDEMPTY", (void *)NULL); - return TCL_ERROR; - } - regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); - } - /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. @@ -704,15 +633,13 @@ Tcl_RegsubObjCmd( } else { objPtr = objv[1]; } - wstring = TclGetUnicodeFromObj(objPtr, &wlen); + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } - if (!command) { - wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); - } + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); result = TCL_OK; @@ -747,7 +674,7 @@ Tcl_RegsubObjCmd( break; } if (numMatches == 0) { - resultPtr = TclNewUnicodeObj(wstring, 0); + resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* @@ -755,7 +682,7 @@ Tcl_RegsubObjCmd( * specified. */ - TclAppendUnicodeToObj(resultPtr, wstring, offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -768,91 +695,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - TclAppendUnicodeToObj(resultPtr, wstring + offset, start); - - /* - * In command-prefix mode, the substitutions are added as quoted - * arguments to the subSpec to form a command, that is then executed - * and the result used as the string to substitute in. Actually, - * everything is passed through Tcl_EvalObjv, as that's much faster. - */ - - if (command) { - Tcl_Obj **args = NULL, **parts; - Tcl_Size numArgs; - - TclListObjGetElements(interp, subPtr, &numParts, &parts); - numArgs = numParts + info.nsubs + 1; - args = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * numArgs); - memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); - - for (idx = 0 ; idx <= info.nsubs ; idx++) { - subStart = info.matches[idx].start; - subEnd = info.matches[idx].end; - if ((subStart >= 0) && (subEnd >= 0)) { - args[idx + numParts] = TclNewUnicodeObj( - wstring + offset + subStart, subEnd - subStart); - } else { - TclNewObj(args[idx + numParts]); - } - Tcl_IncrRefCount(args[idx + numParts]); - } - - /* - * At this point, we're locally holding the references to the - * argument words we added for this time round the loop, and the - * subPtr is holding the references to the words that the user - * supplied directly. None are zero-refcount, which is important - * because Tcl_EvalObjv is "hairy monster" in terms of refcount - * handling, being able to optionally add references to any of its - * argument words. We'll drop the local refs immediately - * afterwards; subPtr is handled in the main exit stanza. - */ - - result = Tcl_EvalObjv(interp, numArgs, args, 0); - for (idx = 0 ; idx <= info.nsubs ; idx++) { - TclDecrRefCount(args[idx + numParts]); - } - ckfree(args); - if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (%s substitution computation script)", - options[REGSUB_COMMAND])); - } - goto done; - } - - Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); - Tcl_ResetResult(interp); - - /* - * Refetch the unicode, in case the representation was smashed by - * the user code. - */ - - wstring = TclGetUnicodeFromObj(objPtr, &wlen); - - offset += end; - if (end == 0 || start == end) { - /* - * Always consume at least one character of the input string - * in order to prevent infinite loops, even when we - * technically matched the empty string; we must not match - * again at the same spot. - */ - - if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); - } - offset++; - } - if (all) { - continue; - } else { - break; - } - } + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* * Append the subSpec argument to the variable, making appropriate @@ -872,7 +715,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -886,7 +729,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -894,7 +737,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -906,7 +749,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -916,7 +759,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -928,7 +771,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -953,11 +796,12 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { + Tcl_AppendResult(interp, "couldn't set variable \"", + TclGetString(objv[3]), "\"", NULL); result = TCL_ERROR; } else { /* @@ -965,7 +809,7 @@ Tcl_RegsubObjCmd( * holding the number of matches. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* @@ -1007,12 +851,12 @@ Tcl_RegsubObjCmd( int Tcl_RenameObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Arbitrary value passed to the command. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *oldName, *newName; + char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); @@ -1043,7 +887,7 @@ Tcl_RenameObjCmd( int Tcl_ReturnObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1057,7 +901,7 @@ Tcl_ReturnObjCmd( */ int explicitResult = (0 == (objc % 2)); - Tcl_Size numOptionWords = objc - 1 - explicitResult; + int numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { @@ -1090,28 +934,15 @@ Tcl_ReturnObjCmd( int Tcl_SourceObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv); -} - -int -TclNRSourceObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *encodingName = NULL; Tcl_Obj *fileName; - int result; - void **pkgFiles = NULL; - void *names = NULL; - if (objc < 2 || objc > 4) { + if (objc != 2 && objc !=4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1119,7 +950,7 @@ TclNRSourceObjCmd( fileName = objv[objc-1]; if (objc == 4) { - static const char *const options[] = { + static const char *options[] = { "-encoding", NULL }; int index; @@ -1129,30 +960,9 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } else if (objc == 3) { - /* Handle undocumented -nopkg option. This should only be - * used by the internal ::tcl::Pkg::source utility function. */ - static const char *const nopkgoptions[] = { - "-nopkg", NULL - }; - int index; - - if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, - "option", TCL_EXACT, &index)) { - return TCL_ERROR; - } - pkgFiles = (void **)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); - /* Make sure that during the following TclNREvalFile no filenames - * are recorded for inclusion in the "package files" command */ - names = *pkgFiles; - *pkgFiles = NULL; - } - result = TclNREvalFile(interp, fileName, encodingName); - if (pkgFiles) { - /* restore "tclPkgFiles" assocdata to how it was. */ - *pkgFiles = names; } - return result; + + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* @@ -1174,17 +984,16 @@ TclNRSourceObjCmd( int Tcl_SplitObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch = 0; + Tcl_UniChar ch; int len; const char *splitChars; - const char *stringPtr; - const char *end; - Tcl_Size splitCharLen, stringLen; + char *stringPtr, *end; + int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { @@ -1199,7 +1008,7 @@ Tcl_SplitObjCmd( stringPtr = TclGetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; - TclNewObj(listPtr); + listPtr = Tcl_NewObj(); if (stringLen == 0) { /* @@ -1223,7 +1032,12 @@ Tcl_SplitObjCmd( for ( ; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew); + + /* + * Assume Tcl_UniChar is an integral type... + */ + + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); @@ -1231,24 +1045,24 @@ Tcl_SplitObjCmd( * Don't need to fiddle with refcount... */ - Tcl_SetHashValue(hPtr, objPtr); + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { - objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); + objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); } else if (splitCharLen == 1) { - const char *p; + 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 + * only true for the one-char ASCII case, as one unicode char is > 1 * byte in length. */ - while (*stringPtr && (p=strchr(stringPtr,*splitChars)) != NULL) { + while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); stringPtr = p + 1; @@ -1256,9 +1070,10 @@ Tcl_SplitObjCmd( TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { - const char *element, *p, *splitEnd; - Tcl_Size splitLen; - int splitChar; + char *element; + const char *p, *splitEnd; + int splitLen; + Tcl_UniChar splitChar; /* * Normal case: split on any of a given set of characters. Discard @@ -1293,8 +1108,7 @@ Tcl_SplitObjCmd( * StringFirstCmd -- * * 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. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1307,12 +1121,13 @@ Tcl_SplitObjCmd( static int StringFirstCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size start = 0; + Tcl_UniChar *ustring1, *ustring2; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1320,14 +1135,81 @@ StringFirstCmd( return TCL_ERROR; } + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + if (objc == 4) { - Tcl_Size end = TclGetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) { + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + + 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 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 (length1 > 0 && length1 <= length2) { + register Tcl_UniChar *p, *end; + + 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; + } + } + } + + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ + + if ((match != -1) && (objc == 4)) { + match += start; } - Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start)); + + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } @@ -1337,8 +1219,7 @@ StringFirstCmd( * 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. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1351,27 +1232,80 @@ StringFirstCmd( static int StringLastCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size last = TCL_SIZE_MAX; + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?lastIndex?"); + "needleString haystackString ?startIndex?"); return TCL_ERROR; } + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + if (objc == 4) { - Tcl_Size end = TclGetCharLength(objv[2]) - 1; + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) { + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } + + /* + * Reread to prevent shimmering problems. + */ + + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + + 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, TclStringLast(objv[1], objv[2], last)); + + /* + * 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 (length1 > 0 && length1 <= length2) { + for (; p >= ustring2; p--) { + /* + * Scan backwards to find the first character. + */ + + if ((*p == *ustring1) && !memcmp(ustring1, p, + sizeof(Tcl_UniChar) * (size_t)length1)) { + match = p - ustring2; + break; + } + } + } + + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } @@ -1395,12 +1329,12 @@ StringLastCmd( static int StringIndexCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size index, end; + int length, index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); @@ -1408,38 +1342,39 @@ StringIndexCmd( } /* - * Get the char length to calculate what 'end' means. + * 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. */ - end = TclGetCharLength(objv[1]) - 1; - if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) { - return TCL_ERROR; - } - - if ((index >= 0) && (index <= end)) { - int ch = TclGetUniChar(objv[1], index); + if (TclIsPureByteArray(objv[1])) { + const unsigned char *string = + Tcl_GetByteArrayFromObj(objv[1], &length); - if (ch == -1) { - return TCL_OK; + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ + return TCL_ERROR; } - + string = Tcl_GetByteArrayFromObj(objv[1], &length); + if ((index >= 0) && (index < length)) { + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1)); + } + } else { /* - * If we have a ByteArray object, we're careful to generate a new - * bytearray for a result. + * Get Unicode char length to calulate what 'end' means. */ - if (TclIsPureByteArray(objv[1])) { - unsigned char uch = UCHAR(ch); + length = Tcl_GetCharLength(objv[1]); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); - } else { - char buf[4] = ""; + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ + return TCL_ERROR; + } + if ((index >= 0) && (index < length)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; - end = Tcl_UniCharToUtf(ch, buf); - if ((ch >= 0xD800) && (end < 3)) { - end += Tcl_UniCharToUtf(-1, buf + end); - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); + ch = Tcl_GetUniChar(objv[1], index); + length = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } return TCL_OK; @@ -1448,63 +1383,6 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * - * StringInsertCmd -- - * - * This procedure is invoked to process the "string insert" 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 -StringInsertCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - Tcl_Size length; /* String length */ - Tcl_Size index; /* Insert index */ - Tcl_Obj *outObj; /* Output object */ - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); - return TCL_ERROR; - } - - length = TclGetCharLength(objv[1]); - if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { - return TCL_ERROR; - } - - if (index < 0) { - index = 0; - } - if (index > length) { - index = length; - } - - outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], - TCL_STRING_IN_PLACE); - - if (outObj != NULL) { - Tcl_SetObjResult(interp, outObj); - return TCL_OK; - } - - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -1522,37 +1400,37 @@ StringInsertCmd( static int StringIsCmd( - TCL_UNUSED(void *), + 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[] = { + static const char *isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "dict", "digit", "double", - "entier", "false", "graph", "integer", - "list", "lower", "print", "punct", - "space", "true", "upper", - "wideinteger", "wordchar", "xdigit", NULL + "boolean", "digit", "double", "false", + "graph", "integer", "list", "lower", + "print", "punct", "space", "true", + "upper", "wideinteger", "wordchar", "xdigit", + NULL }; - enum isClassesEnum { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DICT, 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 + 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_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[] = { + static const char *isOptions[] = { "-strict", "-failindex", NULL }; - enum isOptionsEnum { + enum isOptions { OPT_STRICT, OPT_FAILIDX }; @@ -1574,7 +1452,7 @@ StringIsCmd( &idx2) != TCL_OK) { return TCL_ERROR; } - switch ((enum isOptionsEnum) idx2) { + switch ((enum isOptions) idx2) { case OPT_STRICT: strict = 1; break; @@ -1593,7 +1471,7 @@ StringIsCmd( /* * 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 occurring (as, for example, + * because we don't want any conversion of type occuring (as, for example, * Tcl_Get*FromObj would do). */ @@ -1603,7 +1481,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch ((enum isClassesEnum) index) { + switch ((enum isClasses) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -1616,80 +1494,34 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasInternalRep(objPtr, &tclBooleanType) - && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { + if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { if (strict) { result = 0; } else { string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if (index != STR_IS_BOOL) { - TclGetBooleanFromObj(NULL, objPtr, &i); - if ((index == STR_IS_TRUE) ^ i) { - result = 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_DICT: { - int dresult; - Tcl_Size dsize; - - dresult = Tcl_DictObjSize(interp, objPtr, &dsize); - Tcl_ResetResult(interp); - result = (dresult == TCL_OK) ? 1 : 0; - if (dresult != TCL_OK && failVarObj != NULL) { - /* - * Need to figure out where the list parsing failed, which is - * fairly expensive. This is adapted from the core of - * SetDictFromAny(). - */ - - const char *elemStart, *nextElem; - Tcl_Size lenRemain, elemSize; - const char *p; - - 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; - - /* - * 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 = TclGetCharLength(tmpStr); - TclDecrRefCount(tmpStr); - break; - } - } - } - break; - } case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasInternalRep(objPtr, &tclDoubleType) || - TclHasInternalRep(objPtr, &tclIntType) || - TclHasInternalRep(objPtr, &tclBignumType)) { + /* TODO */ + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType) || +#ifndef NO_WIDE_TYPE + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1700,7 +1532,7 @@ StringIsCmd( goto str_is_done; } end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, (const char **) &stop, 0) != TCL_OK) { result = 0; failat = 0; @@ -1708,7 +1540,8 @@ StringIsCmd( failat = stop - string1; if (stop < end) { result = 0; - TclFreeInternalRep(objPtr); + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } break; @@ -1717,53 +1550,16 @@ StringIsCmd( chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: - case STR_IS_ENTIER: - if (TclHasInternalRep(objPtr, &tclIntType) || - TclHasInternalRep(objPtr, &tclBignumType)) { + if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { break; } - string1 = TclGetStringFromObj(objPtr, &length1); - if (length1 == 0) { - if (strict) { - result = 0; - } - goto str_is_done; - } - end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, - (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { - if (stop == end) { - /* - * Entire string parses as an integer. - */ - - break; - } else { - /* - * 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; - TclFreeInternalRep(objPtr); - } - } else { - /* - * No prefix is a valid integer. Fail at beginning. - */ - - result = 0; - failat = 0; - } - break; + goto failedIntParse; case STR_IS_WIDE: - if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { break; } + failedIntParse: string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1781,7 +1577,7 @@ StringIsCmd( break; } end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { if (stop == end) { /* @@ -1801,7 +1597,8 @@ StringIsCmd( */ failat = stop - string1; - TclFreeInternalRep(objPtr); + TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } else { /* @@ -1829,8 +1626,8 @@ StringIsCmd( */ const char *elemStart, *nextElem; - Tcl_Size lenRemain, elemSize; - const char *p; + int lenRemain, elemSize; + register const char *p; string1 = TclGetStringFromObj(objPtr, &length1); end = string1 + length1; @@ -1851,11 +1648,11 @@ StringIsCmd( * if it is the first "element" that has the failure. */ - while (TclIsSpaceProcM(*p)) { + while (TclIsSpaceProc(*p)) { p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = TclGetCharLength(tmpStr); + failat = Tcl_GetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1896,10 +1693,8 @@ StringIsCmd( } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { - int ucs4; - - length2 = TclUtfToUniChar(string1, &ucs4); - if (!chcomp(ucs4)) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { result = 0; break; } @@ -1912,11 +1707,10 @@ StringIsCmd( */ str_is_done: - if ((result == 0) && (failVarObj != NULL)) { - TclNewIndexObj(objPtr, failat); - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, objPtr, TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } + 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; @@ -1933,7 +1727,7 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); + return (character >= 0) && (character < 0x80) && isxdigit(character); } /* @@ -1956,16 +1750,16 @@ UniCharIsHexDigit( static int StringMapCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2, mapElemc, index; + 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*, size_t); + int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); @@ -1976,24 +1770,21 @@ StringMapCmd( const char *string = TclGetStringFromObj(objv[1], &length2); if ((length2 > 1) && - strncmp(string, "-nocase", length2) == 0) { + 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, (void *)NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20.1 for illustration why!) + * inconsistencies (see test string-10.20 for illustration why!) */ - if (!TclHasStringRep(objv[objc-2]) - && TclHasInternalRep(objv[objc-2], &tclDictType)) { + if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ int i, done; Tcl_DictSearch search; @@ -2020,7 +1811,8 @@ StringMapCmd( * adapt this code... */ - mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + mapElemv = (Tcl_Obj **) + 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) { @@ -2046,8 +1838,6 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", - "UNBALANCED", (void *)NULL); return TCL_ERROR; } } @@ -2063,7 +1853,7 @@ StringMapCmd( } else { sourceObj = objv[objc-1]; } - ustring1 = TclGetUnicodeFromObj(sourceObj, &length1); + ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. @@ -2073,13 +1863,13 @@ StringMapCmd( } end = ustring1 + length1; - strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; + strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); /* * Force result to be Unicode */ - resultPtr = TclNewUnicodeObj(ustring1, 0); + resultPtr = Tcl_NewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* @@ -2089,11 +1879,10 @@ StringMapCmd( * larger strings. */ - Tcl_Size mapLen; - int u2lc; - Tcl_UniChar *mapString; + int mapLen; + Tcl_UniChar *mapString, u2lc; - ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* @@ -2102,7 +1891,7 @@ StringMapCmd( ustring1 = end; } else { - mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || @@ -2110,36 +1899,37 @@ StringMapCmd( (length2==1 || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - TclAppendUnicodeToObj(resultPtr, mapString, mapLen); + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { - Tcl_UniChar **mapStrings; - Tcl_Size *mapLens; - int *u2lc = NULL; + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; /* - * Precompute pointers to the Unicode string and length. This saves us + * 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. */ - mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*sizeof(Tcl_UniChar *)*2); - mapLens = (Tcl_Size *)TclStackAlloc(interp, mapElemc * sizeof(Tcl_Size) * 2); + mapStrings = (Tcl_UniChar **) TclStackAlloc(interp, + mapElemc * 2 * sizeof(Tcl_UniChar *)); + mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int)); + u2lc = (Tcl_UniChar *) TclStackAlloc(interp, + mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); @@ -2157,13 +1947,13 @@ StringMapCmd( (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || - !strCmpFn(ustring2, ustring1, length2))) { + !strCmpFn(ustring2, ustring1, (unsigned) length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1-p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2176,10 +1966,10 @@ StringMapCmd( ustring1 = p - 1; /* - * Append the map value to the Unicode string. + * Append the map value to the unicode string. */ - TclAppendUnicodeToObj(resultPtr, + Tcl_AppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2196,7 +1986,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: @@ -2229,7 +2019,7 @@ StringMapCmd( static int StringMatchCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2242,17 +2032,15 @@ StringMatchCmd( } if (objc == 4) { - Tcl_Size length; + int length; const char *string = TclGetStringFromObj(objv[1], &length); if ((length > 1) && - strncmp(string, "-nocase", length) == 0) { + strncmp(string, "-nocase", (size_t) length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, (void *)NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } @@ -2281,12 +2069,13 @@ StringMatchCmd( static int StringRangeCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size first, last, end; + const unsigned char *string; + int length, first, last; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "string first last"); @@ -2294,19 +2083,46 @@ StringRangeCmd( } /* - * Get the length in actual characters; Then reduce it by one because - * 'end' refers to the last character, not one past it. + * 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. */ - end = TclGetCharLength(objv[1]) - 1; + if (TclIsPureByteArray(objv[1])) { + string = Tcl_GetByteArrayFromObj(objv[1], &length); + length--; + } else { + /* + * Get the length in actual characters. + */ - if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { + string = NULL; + length = Tcl_GetCharLength(objv[1]) - 1; + } + + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { return TCL_ERROR; } - if (last >= 0) { - Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last)); + if (first < 0) { + first = 0; + } + if (last >= length) { + last = length; + } + if (last >= first) { + if (string != NULL) { + /* + * Reread the string to prevent shimmering nasties. + */ + + string = Tcl_GetByteArrayFromObj(objv[1], &length); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj(string+first, last - first + 1)); + } else { + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + } } return TCL_OK; } @@ -2331,12 +2147,14 @@ StringRangeCmd( static int StringReptCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + const char *string1; + char *string2; + int count, index, length1, length2; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2354,17 +2172,68 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + goto done; } else if (count < 1) { - return TCL_OK; + goto done; + } + string1 = TclGetStringFromObj(objv[1], &length1); + if (length1 <= 0) { + goto done; } - resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); - if (resultPtr) { - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + /* + * 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)); + 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)); + return TCL_ERROR; } - 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; } /* @@ -2387,57 +2256,46 @@ StringReptCmd( static int StringRplcCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size first, last, end; + Tcl_UniChar *ustring; + int first, last, length; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } - end = TclGetCharLength(objv[1]) - 1; + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length--; - if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { + if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || + TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ return TCL_ERROR; } - /* - * The following test screens out most empty substrings as candidates for - * replacement. When they are detected, no replacement is done, and the - * result is the original string. - */ - - if ((last < 0) || /* Range ends before start of string */ - (first > end) || /* Range begins after end of string */ - (last < first)) { /* Range begins after it starts */ - /* - * BUT!!! when (end < 0) -- an empty original string -- we can - * have (first <= end < 0 <= last) and an empty string is permitted - * to be replaced. - */ - + 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 (last > end) { - last = end; - } - - resultPtr = TclStringReplace(interp, objv[1], first, - last + 1 - first, (objc == 5) ? objv[4] : NULL, - TCL_STRING_IN_PLACE); - if (resultPtr == NULL) { - return TCL_ERROR; + resultPtr = Tcl_NewUnicodeObj(ustring, first); + if (objc == 5) { + Tcl_AppendObjToObj(resultPtr, objv[4]); + } + if (last < length) { + Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, + length - last); } Tcl_SetObjResult(interp, resultPtr); } @@ -2464,7 +2322,7 @@ StringRplcCmd( static int StringRevCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2474,7 +2332,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); + Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); return TCL_OK; } @@ -2484,7 +2342,9 @@ StringRevCmd( * StringStartCmd -- * * This procedure is invoked to process the "string wordstart" Tcl - * command. See the user documentation for details on what it does. + * 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. @@ -2497,55 +2357,44 @@ StringRevCmd( static int StringStartCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch; - const Tcl_UniChar *p, *string; - Tcl_Size cur, index, length; - Tcl_Obj *obj; + 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 = TclGetUnicodeFromObj(objv[1], &length); - if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { + string = TclGetStringFromObj(objv[1], &length); + numChars = Tcl_NumUtfChars(string, length); + if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { return TCL_ERROR; } - if (index >= length) { - index = length - 1; + string = TclGetStringFromObj(objv[1], &length); + if (index >= numChars) { + index = numChars - 1; } cur = 0; if (index > 0) { - p = &string[index]; - - ch = *p; - for (cur = index; cur != TCL_INDEX_NONE; cur--) { - int delta = 0; - const Tcl_UniChar *next; - + p = Tcl_UtfAtIndex(string, index); + for (cur = index; cur >= 0; cur--) { + TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } - - next = (p > string) ? p - 1 : p; - do { - next += delta; - ch = *next; - delta = 1; - } while (next + delta < p); - p = next; + p = Tcl_UtfPrev(p, string); } if (cur != index) { cur += 1; } } - TclNewIndexObj(obj, cur); - Tcl_SetObjResult(interp, obj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } @@ -2555,7 +2404,8 @@ StringStartCmd( * StringEndCmd -- * * This procedure is invoked to process the "string wordend" Tcl command. - * See the user documentation for details on what it does. + * 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. @@ -2568,33 +2418,34 @@ StringStartCmd( static int StringEndCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int ch; - const Tcl_UniChar *p, *end, *string; - Tcl_Size cur, index, length; - Tcl_Obj *obj; + 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 = TclGetUnicodeFromObj(objv[1], &length); - if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { + 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 < length) { - p = &string[index]; + if (index < numChars) { + p = Tcl_UtfAtIndex(string, index); end = string+length; for (cur = index; p < end; cur++) { - ch = *p++; + p += TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; } @@ -2603,10 +2454,9 @@ StringEndCmd( cur++; } } else { - cur = length; + cur = numChars; } - TclNewIndexObj(obj, cur); - Tcl_SetObjResult(interp, obj); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } @@ -2630,7 +2480,7 @@ StringEndCmd( static int StringEqualCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2641,10 +2491,10 @@ StringEqualCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string2; - int i, match, nocase = 0; - Tcl_Size length; - Tcl_WideInt reqlength = -1; + 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: @@ -2654,27 +2504,21 @@ StringEqualCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length); - if ((length > 1) && !strncmp(string2, "-nocase", length)) { + string2 = TclGetStringFromObj(objv[i], &length2); + if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { nocase = 1; - } else if ((length > 1) - && !strncmp(string2, "-length", length)) { + } else if ((length2 > 1) + && !strncmp(string2, "-length", (size_t)length2)) { if (i+1 >= objc-2) { goto str_cmp_args; } - i++; - if (Tcl_GetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + ++i; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } - if ((Tcl_WideUInt)reqlength > TCL_SIZE_MAX) { - reqlength = -1; - } } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string2)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, (void *)NULL); + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); return TCL_ERROR; } } @@ -2685,7 +2529,80 @@ StringEqualCmd( */ objv += objc-2; - match = TclStringCmp(objv[0], objv[1], 1, nocase, reqlength); + + if ((reqlength == 0) || (objv[0] == objv[1])) { + /* + * Always match at 0 chars of if it is the same obj. + */ + + 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) { + /* + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } @@ -2710,7 +2627,7 @@ StringEqualCmd( static int StringCmpCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2721,34 +2638,11 @@ StringCmpCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - int match, nocase, status; - Tcl_Size reqlength = -1; - - status = StringCmpOpts(interp, objc, objv, &nocase, &reqlength); - if (status != TCL_OK) { - return status; - } + 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; - objv += objc-2; - match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); - return TCL_OK; -} - -int -StringCmpOpts( - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[], /* Argument objects. */ - int *nocase, - Tcl_Size *reqlength) -{ - int i; - Tcl_Size length; - const char *string; - Tcl_WideInt wreqlength = -1; - - *nocase = 0; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, @@ -2757,77 +2651,104 @@ StringCmpOpts( } for (i = 1; i < objc-2; i++) { - string = TclGetStringFromObj(objv[i], &length); - if ((length > 1) && !strncmp(string, "-nocase", length)) { - *nocase = 1; - } else if ((length > 1) - && !strncmp(string, "-length", length)) { + 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 (Tcl_GetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { + ++i; + if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } - if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { - *reqlength = -1; - } else { - *reqlength = wreqlength; - } } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, (void *)NULL); + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); return TCL_ERROR; } } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * StringCatCmd -- - * - * This procedure is invoked to process the "string cat" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ -static int -StringCatCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *objResultPtr; + /* + * From now on, we only access the two objects at the end of the argument + * array. + */ + + objv += objc-2; - if (objc < 2) { + if ((reqlength == 0) || (objv[0] == objv[1])) { /* - * If there are no args, the result is an empty object. - * Just leave the preset empty interp result. + * Always match at 0 chars of if it is the same obj. */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } - objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); + 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... :^) + */ - if (objResultPtr) { - Tcl_SetObjResult(interp, objResultPtr); - return TCL_OK; + 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); + } } - 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. + */ + + reqlength = length + 1; + } + + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; + } + + Tcl_SetObjResult(interp, + Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); + return TCL_OK; } /* @@ -2848,10 +2769,10 @@ StringCatCmd( * *---------------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) + static int StringBytesCmd( - TCL_UNUSED(ClientData), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2864,10 +2785,9 @@ StringBytesCmd( } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } -#endif /* *---------------------------------------------------------------------- @@ -2889,17 +2809,30 @@ StringBytesCmd( static int StringLenCmd( - TCL_UNUSED(void *), + 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; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[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. + */ + + if (objv[1]->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(objv[1], &length); + } else { + length = Tcl_GetCharLength(objv[1]); + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } @@ -2923,14 +2856,13 @@ StringLenCmd( static int StringLowerCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -2946,11 +2878,11 @@ StringLowerCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_Size first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -2973,8 +2905,8 @@ StringLowerCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3008,14 +2940,13 @@ StringLowerCmd( static int StringUpperCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3031,11 +2962,11 @@ StringUpperCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_Size first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3058,8 +2989,8 @@ StringUpperCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3093,14 +3024,13 @@ StringUpperCmd( static int StringTitleCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2; - const char *string1; - char *string2; + int length1, length2; + char *string1, *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3116,11 +3046,11 @@ StringTitleCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_Size first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; - length1 = TclNumUtfChars(string1, length1) - 1; + length1 = Tcl_NumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3143,8 +3073,8 @@ StringTitleCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = TclUtfAtIndex(string1, first); - end = TclUtfAtIndex(start, last - first + 1); + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3178,7 +3108,7 @@ StringTitleCmd( static int StringTrimCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3189,15 +3119,16 @@ StringTrimCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); - triml = TclTrim(string1, length1, string2, length2, &trimr); + triml = TclTrimLeft(string1, length1, string2, length2); + trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2); Tcl_SetObjResult(interp, Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); @@ -3225,20 +3156,19 @@ StringTrimCmd( static int StringTrimLCmd( - TCL_UNUSED(void *), + 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; - Tcl_Size length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3272,20 +3202,19 @@ StringTrimLCmd( static int StringTrimRCmd( - TCL_UNUSED(void *), + 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; - Tcl_Size length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = tclDefaultTrimSet; - length2 = strlen(tclDefaultTrimSet); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3326,33 +3255,29 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { -#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) - {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, -#endif - {"cat", StringCatCmd, TclCompileStringCatCmd, 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}, - {"insert", StringInsertCmd, TclCompileStringInsertCmd, 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} + {"bytelength", StringBytesCmd, NULL}, + {"compare", StringCmpCmd, TclCompileStringCmpCmd}, + {"equal", StringEqualCmd, TclCompileStringEqualCmd}, + {"first", StringFirstCmd, NULL}, + {"index", StringIndexCmd, TclCompileStringIndexCmd}, + {"is", StringIsCmd, NULL}, + {"last", StringLastCmd, NULL}, + {"length", StringLenCmd, TclCompileStringLenCmd}, + {"map", StringMapCmd, NULL}, + {"match", StringMatchCmd, TclCompileStringMatchCmd}, + {"range", StringRangeCmd, NULL}, + {"repeat", StringReptCmd, NULL}, + {"replace", StringRplcCmd, NULL}, + {"reverse", StringRevCmd, NULL}, + {"tolower", StringLowerCmd, NULL}, + {"toupper", StringUpperCmd, NULL}, + {"totitle", StringTitleCmd, NULL}, + {"trim", StringTrimCmd, NULL}, + {"trimleft", StringTrimLCmd, NULL}, + {"trimright", StringTrimRCmd, NULL}, + {"wordend", StringEndCmd, NULL}, + {"wordstart", StringStartCmd, NULL}, + {NULL, NULL, NULL} }; return TclMakeEnsemble(interp, "string", stringImplMap); @@ -3377,24 +3302,30 @@ TclInitStringCmd( */ int -TclSubstOptions( - Tcl_Interp *interp, - Tcl_Size numOpts, - Tcl_Obj *const opts[], - int *flagPtr) +Tcl_SubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { - static const char *const substOptions[] = { + static const char *substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", NULL }; - enum { + enum substOptions { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - int i, flags = TCL_SUBST_ALL; + Tcl_Obj *resultPtr; + int flags, i; - for (i = 0; i < numOpts; i++) { + /* + * Parse command-line options. + */ + + flags = TCL_SUBST_ALL; + for (i = 1; i < (objc-1); i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3412,39 +3343,23 @@ TclSubstOptions( Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - *flagPtr = flags; - return TCL_OK; -} - -int -Tcl_SubstObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv); -} - -int -TclNRSubstObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int flags; - - if (objc < 2) { + if (i != objc-1) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { + /* + * Perform the substitution. + */ + + resultPtr = Tcl_SubstObj(interp, objv[i], flags); + + if (resultPtr == NULL) { return TCL_ERROR; } - return Tcl_NRSubstObj(interp, objv[objc-1], flags); + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } /* @@ -3466,24 +3381,14 @@ TclNRSubstObjCmd( int Tcl_SwitchObjCmd( - void *clientData, + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv); -} -int -TclNRSwitchObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i, index, mode, foundmode, splitObjs, numMatchesSaved; - int noCase; - Tcl_Size patternLength, j; - const char *pattern; + int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved; + int noCase, patternLength; + char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *const *savedObjv = objv; Tcl_RegExp regExpr = NULL; @@ -3499,16 +3404,16 @@ TclNRSwitchObjCmd( * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ - static const char *const options[] = { + static const char *options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; - enum switchOptionsEnum { + enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = TclUtfCmp; + strCmpFn_t strCmpFn = strcmp; mode = OPT_EXACT; foundmode = 0; @@ -3524,7 +3429,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum switchOptionsEnum) index) { + switch ((enum options) index) { /* * General options. */ @@ -3547,16 +3452,15 @@ TclNRSwitchObjCmd( * 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", (void *)NULL); + Tcl_AppendResult(interp, "bad option \"", + TclGetString(objv[i]), "\": ", options[mode], + " option already found", NULL); return TCL_ERROR; + } else { + foundmode = 1; + mode = index; + break; } - foundmode = 1; - mode = index; - break; /* * Check for TIP#75 options specifying the variables to write @@ -3566,11 +3470,8 @@ TclNRSwitchObjCmd( case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing variable name argument to %s option", - "-indexvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", (void *)NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-indexvar", " option", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3579,11 +3480,8 @@ TclNRSwitchObjCmd( case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "missing variable name argument to %s option", - "-matchvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "NOVAR", (void *)NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-matchvar", " option", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3595,21 +3493,17 @@ TclNRSwitchObjCmd( finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-option ...? string ?pattern body ...? ?default body?"); + "?switches? string pattern body ... ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s option requires -regexp option", "-indexvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", (void *)NULL); + Tcl_AppendResult(interp, + "-indexvar option requires -regexp option", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s option requires -regexp option", "-matchvar")); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "MODERESTRICTION", (void *)NULL); + Tcl_AppendResult(interp, + "-matchvar option requires -regexp option", NULL); return TCL_ERROR; } @@ -3630,9 +3524,9 @@ TclNRSwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - blist = objv[0]; - if (TclListObjLength(interp, objv[0], &objc) != TCL_OK) { + + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } @@ -3642,10 +3536,7 @@ TclNRSwitchObjCmd( if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?-option ...? string {?pattern body ...? ?default body?}"); - return TCL_ERROR; - } - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { + "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } objv = listv; @@ -3659,10 +3550,7 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra switch pattern with no body", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - (void *)NULL); + Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3675,12 +3563,10 @@ TclNRSwitchObjCmd( if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { - 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?", (void *)NULL); + Tcl_AppendResult(interp, ", this may be due to a " + "comment incorrectly placed outside of a " + "switch body - see the \"switch\" " + "documentation", NULL); break; } } @@ -3695,11 +3581,9 @@ TclNRSwitchObjCmd( */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no body specified for pattern \"%s\"", - TclGetString(objv[objc-2]))); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - "FALLTHROUGH", (void *)NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "no body specified for pattern \"", + TclGetString(objv[objc-2]), "\"", NULL); return TCL_ERROR; } @@ -3738,35 +3622,36 @@ TclNRSwitchObjCmd( } } goto matchFound; - } - - 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) { + } 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) { return TCL_ERROR; - } else if (matched) { - goto matchFoundRegexp; + } else { + int matched = Tcl_RegExpExecObj(interp, regExpr, + stringObj, 0, numMatchesSaved, 0); + + if (matched < 0) { + return TCL_ERROR; + } else if (matched) { + goto matchFoundRegexp; + } } + break; } - break; } } return TCL_OK; @@ -3797,11 +3682,10 @@ TclNRSwitchObjCmd( Tcl_Obj *rangeObjAry[2]; if (info.matches[j].end > 0) { - TclNewIndexObj(rangeObjAry[0], info.matches[j].start); - TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1); + rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { - TclNewIntObj(rangeObjAry[1], -1); - rangeObjAry[0] = rangeObjAry[1]; + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); } /* @@ -3815,12 +3699,8 @@ TclNRSwitchObjCmd( if (matchVarObj != NULL) { Tcl_Obj *substringObj; - if (info.matches[j].end > 0) { - substringObj = TclGetRange(stringObj, - info.matches[j].start, info.matches[j].end-1); - } else { - TclNewObj(substringObj); - } + substringObj = Tcl_GetRange(stringObj, + info.matches[j].start, info.matches[j].end-1); /* * Never fails; the object is always clean at this point. @@ -3867,7 +3747,7 @@ TclNRSwitchObjCmd( */ matchFound: - ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); + ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *iPtr->cmdFramePtr; if (splitObjs) { @@ -3882,7 +3762,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_BC) { /* * Type BC => ctxPtr->data.eval.path is not used. - * ctxPtr->data.tebc.codePtr is used instead. + * ctxPtr->data.tebc.codePtr is used instead. */ TclGetSrcInfoForPc(ctxPtr); @@ -3897,7 +3777,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3911,7 +3791,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3937,31 +3817,9 @@ TclNRSwitchObjCmd( * TIP #280: Make invoking context available to switch branch. */ - Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, - INT2PTR(pc), (void *)pattern); - return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); -} - -static int -SwitchPostProc( - void *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 = (CmdFrame *)data[1]; - int pc = PTR2INT(data[2]); - const char *pattern = (const char *)data[3]; - Tcl_Size patternLength = strlen(pattern); - - /* - * Clean up TIP 280 context information - */ - + result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); if (splitObjs) { - ckfree(ctxPtr->line); + ckfree((char *) ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -3982,7 +3840,7 @@ SwitchPostProc( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, - (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); + (overflow ? "..." : ""), interp->errorLine)); } TclStackFree(interp, ctxPtr); return result; @@ -3991,68 +3849,6 @@ SwitchPostProc( /* *---------------------------------------------------------------------- * - * 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. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ThrowObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *options; - Tcl_Size 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 (TclListObjLength(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", - (void *)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 @@ -4069,14 +3865,14 @@ Tcl_ThrowObjCmd( int Tcl_TimeObjCmd( - TCL_UNUSED(void *), + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr; Tcl_Obj *objs[4]; - int i, result; + register int i, result; int count; double totalMicroSec; #ifndef TCL_WIDE_CLICKS @@ -4105,7 +3901,7 @@ Tcl_TimeObjCmd( start = TclpGetWideClicks(); #endif while (i-- > 0) { - result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); + result = Tcl_EvalObjEx(interp, objPtr, 0); if (result != TCL_OK) { return result; } @@ -4124,9 +3920,9 @@ Tcl_TimeObjCmd( * Use int obj since we know time is not fractional. [Bug 1202178] */ - TclNewIntObj(objs[0], (count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec); + objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); } else { - TclNewDoubleObj(objs[0], totalMicroSec/count); + objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); } /* @@ -4145,19 +3941,17 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * - * Tcl_TimeRateObjCmd -- - * - * This object-based procedure is invoked to process the "timerate" Tcl - * command. + * Tcl_WhileObjCmd -- * - * This is similar to command "time", except the execution limited by - * given time (in milliseconds) instead of repetition count. + * This procedure is invoked to process the "while" Tcl command. See the + * user documentation for details on what it does. * - * Example: - * timerate {after 5} 1000; # equivalent to: time {after 5} [expr 1000/5] + * 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 object result. + * A standard Tcl result. * * Side effects: * See the user documentation. @@ -4166,1104 +3960,44 @@ Tcl_TimeObjCmd( */ int -Tcl_TimeRateObjCmd( - TCL_UNUSED(void *), +Tcl_WhileObjCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - static double measureOverhead = 0; - /* global measure-overhead */ - double overhead = -1; /* given measure-overhead */ - Tcl_Obj *objPtr; - int result, i; - Tcl_Obj *calibrate = NULL, *direct = NULL; - Tcl_WideUInt count = 0; /* Holds repetition count */ - Tcl_WideInt maxms = WIDE_MIN; - /* Maximal running time (in milliseconds) */ - Tcl_WideUInt maxcnt = WIDE_MAX; - /* Maximal count of iterations. */ - Tcl_WideUInt threshold = 1; /* Current threshold for check time (faster - * repeat count without time check) */ - Tcl_WideUInt maxIterTm = 1; /* Max time of some iteration as max - * threshold, additionally avoiding divide to - * zero (i.e., never < 1) */ - unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid - * growth of execution time. */ - Tcl_WideInt start, middle, stop; -#ifndef TCL_WIDE_CLICKS - Tcl_Time now; -#endif /* !TCL_WIDE_CLICKS */ - static const char *const options[] = { - "-direct", "-overhead", "-calibrate", "--", NULL - }; - enum timeRateOptionsEnum { - TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST - }; - NRE_callback *rootPtr; - ByteCode *codePtr = NULL; - - for (i = 1; i < objc - 1; i++) { - int index; - - if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, - &index) != TCL_OK) { - break; - } - if (index == TMRT_LAST) { - i++; - break; - } - switch ((enum timeRateOptionsEnum)index) { - case TMRT_EV_DIRECT: - direct = objv[i]; - break; - case TMRT_OVERHEAD: - if (++i >= objc - 1) { - goto usage; - } - if (Tcl_GetDoubleFromObj(interp, objv[i], &overhead) != TCL_OK) { - return TCL_ERROR; - } - break; - case TMRT_CALIBRATE: - calibrate = objv[i]; - break; - case TMRT_LAST: - break; - } - } + int result, value; + Interp *iPtr = (Interp *) interp; - if (i >= objc || i < objc - 3) { - usage: - Tcl_WrongNumArgs(interp, 1, objv, - "?-direct? ?-calibrate? ?-overhead double? " - "command ?time ?max-count??"); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } - objPtr = objv[i++]; - if (i < objc) { /* max-time */ - result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms); - if (result != TCL_OK) { - return result; - } - if (i < objc) { /* max-count*/ - Tcl_WideInt v; - - result = Tcl_GetWideIntFromObj(interp, objv[i], &v); - if (result != TCL_OK) { - return result; - } - maxcnt = (v > 0) ? v : 0; - } - } - - /* - * If we are doing calibration. - */ - - if (calibrate) { - /* - * If no time specified for the calibration. - */ - - if (maxms == WIDE_MIN) { - Tcl_Obj *clobjv[6]; - Tcl_WideInt maxCalTime = 5000; - double lastMeasureOverhead = measureOverhead; - - clobjv[0] = objv[0]; - i = 1; - if (direct) { - clobjv[i++] = direct; - } - clobjv[i++] = objPtr; - - /* - * Reset last measurement overhead. - */ - - measureOverhead = (double) 0; - - /* - * Self-call with 100 milliseconds to warm-up, before entering the - * calibration cycle. - */ - - TclNewIntObj(clobjv[i], 100); - Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); - Tcl_DecrRefCount(clobjv[i]); - if (result != TCL_OK) { - return result; - } - - i--; - clobjv[i++] = calibrate; - clobjv[i++] = objPtr; - - /* - * Set last measurement overhead to max. - */ - - measureOverhead = (double) UWIDE_MAX; - - /* - * Run the calibration cycle until it is more precise. - */ - - maxms = -1000; - do { - lastMeasureOverhead = measureOverhead; - TclNewIntObj(clobjv[i], (int) maxms); - Tcl_IncrRefCount(clobjv[i]); - result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); - Tcl_DecrRefCount(clobjv[i]); - if (result != TCL_OK) { - return result; - } - maxCalTime += maxms; - - /* - * Increase maxms for more precise calibration. - */ - - maxms -= -maxms / 4; - - /* - * As long as new value more as 0.05% better - */ - } while ((measureOverhead >= lastMeasureOverhead - || measureOverhead / lastMeasureOverhead <= 0.9995) - && maxCalTime > 0); + while (1) { + result = Tcl_ExprBooleanObj(interp, objv[1], &value); + if (result != TCL_OK) { return result; } - if (maxms == 0) { - /* - * Reset last measurement overhead - */ - - measureOverhead = 0; - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); - return TCL_OK; - } - - /* - * If time is negative, make current overhead more precise. - */ - - if (maxms > 0) { - /* - * Set last measurement overhead to max. - */ - - measureOverhead = (double) UWIDE_MAX; - } else { - maxms = -maxms; - } - } - - if (maxms == WIDE_MIN) { - maxms = 1000; - } - if (overhead == -1) { - overhead = measureOverhead; - } - - /* - * Ensure that resetting of result will not smudge the further - * measurement. - */ - - Tcl_ResetResult(interp); - - /* - * Compile object if needed. - */ - - if (!direct) { - if (TclInterpReady(interp) != TCL_OK) { - return TCL_ERROR; - } - codePtr = TclCompileObj(interp, objPtr, NULL, 0); - TclPreserveByteCode(codePtr); - } - - /* - * Get start and stop time. - */ - -#ifdef TCL_WIDE_CLICKS - start = middle = TclpGetWideClicks(); - - /* - * Time to stop execution (in wide clicks). - */ - - stop = start + (maxms * 1000 / TclpWideClickInMicrosec()); -#else - Tcl_GetTime(&now); - start = now.sec; - start *= 1000000; - start += now.usec; - middle = start; - - /* - * Time to stop execution (in microsecs). - */ - - stop = start + maxms * 1000; -#endif /* TCL_WIDE_CLICKS */ - - /* - * Start measurement. - */ - - if (maxcnt > 0) { - while (1) { - /* - * Evaluate a single iteration. - */ - - count++; - if (!direct) { /* precompiled */ - rootPtr = TOP_CB(interp); - /* - * Use loop optimized TEBC call (TCL_EVAL_DISCARD_RESULT): it's a part of - * iteration, this way evaluation will be more similar to a cycle (also - * avoids extra overhead to set result to interp, etc.) - */ - ((Interp *)interp)->evalFlags |= TCL_EVAL_DISCARD_RESULT; - result = TclNRExecuteByteCode(interp, codePtr); - result = TclNRRunCallbacks(interp, result, rootPtr); - } else { /* eval */ - result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); - } - /* - * Allow break and continue from measurement cycle (used for - * conditional stop and flow control of iterations). - */ - - switch (result) { - case TCL_OK: - break; - case TCL_BREAK: - /* - * Force stop immediately. - */ - threshold = 1; - maxcnt = 0; - /* FALLTHRU */ - case TCL_CONTINUE: - result = TCL_OK; - break; - default: - goto done; - } - - /* - * Don't check time up to threshold. - */ - - if (--threshold > 0) { - continue; - } - - /* - * Check stop time reached, estimate new threshold. - */ - -#ifdef TCL_WIDE_CLICKS - middle = TclpGetWideClicks(); -#else - Tcl_GetTime(&now); - middle = now.sec; - middle *= 1000000; - middle += now.usec; -#endif /* TCL_WIDE_CLICKS */ - - if (middle >= stop || count >= maxcnt) { - break; - } - - /* - * Don't calculate threshold by few iterations, because sometimes - * first iteration(s) can be too fast or slow (cached, delayed - * clean up, etc). - */ - - if (count < 10) { - threshold = 1; - continue; - } - - /* - * Average iteration time in microsecs. - */ - - threshold = (middle - start) / count; - if (threshold > maxIterTm) { - maxIterTm = threshold; - - /* - * Iterations seem to be longer. - */ - - if (threshold > maxIterTm * 2) { - factor *= 2; - if (factor > 50) { - factor = 50; - } - } else { - if (factor < 50) { - factor++; - } - } - } else if (factor > 4) { - /* - * Iterations seem to be shorter. - */ - - if (threshold < (maxIterTm / 2)) { - factor /= 2; - if (factor < 4) { - factor = 4; - } - } else { - factor--; - } - } - - /* - * As relation between remaining time and time since last check, - * maximal some % of time (by factor), so avoid growing of the - * execution time if iterations are not consistent, e.g. was - * continuously on time). - */ - - threshold = ((stop - middle) / maxIterTm) / factor + 1; - if (threshold > 100000) { /* fix for too large threshold */ - threshold = 100000; - } - - /* - * Consider max-count - */ - - if (threshold > maxcnt - count) { - threshold = maxcnt - count; - } - } - } - - { - Tcl_Obj *objarr[8], **objs = objarr; - Tcl_WideUInt usec, val; - int digits; - - /* - * Absolute execution time in microseconds or in wide clicks. - */ - usec = (Tcl_WideUInt)(middle - start); - -#ifdef TCL_WIDE_CLICKS - /* - * convert execution time (in wide clicks) to microsecs. - */ - - usec *= TclpWideClickInMicrosec(); -#endif /* TCL_WIDE_CLICKS */ - - if (!count) { /* no iterations - avoid divide by zero */ - TclNewIntObj(objs[4], 0); - objs[0] = objs[2] = objs[4]; - goto retRes; - } - - /* - * If not calibrating... - */ - - if (!calibrate) { - /* - * Minimize influence of measurement overhead. - */ - - if (overhead > 0) { - /* - * Estimate the time of overhead (microsecs). - */ - - Tcl_WideUInt curOverhead = overhead * count; - - if (usec > curOverhead) { - usec -= curOverhead; - } else { - usec = 0; - } - } - } else { - /* - * Calibration: obtaining new measurement overhead. - */ - - if (measureOverhead > ((double) usec) / count) { - measureOverhead = ((double) usec) / count; - } - TclNewDoubleObj(objs[0], measureOverhead); - TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ - objs += 2; - } - - val = usec / count; /* microsecs per iteration */ - if (val >= 1000000) { - TclNewIntObj(objs[0], val); - } else { - if (val < 10) { - digits = 6; - } else if (val < 100) { - digits = 4; - } else if (val < 1000) { - digits = 3; - } else if (val < 10000) { - digits = 2; - } else { - digits = 1; - } - objs[0] = Tcl_ObjPrintf("%.*f", digits, ((double) usec)/count); - } - - TclNewIntObj(objs[2], count); /* iterations */ - - /* - * Calculate speed as rate (count) per sec - */ - - if (!usec) { - usec++; /* Avoid divide by zero. */ - } - if (count < (WIDE_MAX / 1000000)) { - val = (count * 1000000) / usec; - if (val < 100000) { - if (val < 100) { - digits = 3; - } else if (val < 1000) { - digits = 2; - } else { - digits = 1; - } - objs[4] = Tcl_ObjPrintf("%.*f", - digits, ((double) (count * 1000000)) / usec); - } else { - TclNewIntObj(objs[4], val); - } - } else { - objs[4] = Tcl_NewWideIntObj((count / usec) * 1000000); - } - - retRes: - /* - * Estimated net execution time (in millisecs). - */ - - if (!calibrate) { - if (usec >= 1) { - objs[6] = Tcl_ObjPrintf("%.3f", (double)usec / 1000); - } else { - TclNewIntObj(objs[6], 0); - } - TclNewLiteralStringObj(objs[7], "net-ms"); - } - - /* - * Construct the result as a list because many programs have always - * parsed as such (extracting the first element, typically). - */ - - TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#"); /* mics/# */ - TclNewLiteralStringObj(objs[3], "#"); - TclNewLiteralStringObj(objs[5], "#/sec"); - Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr)); - } - - done: - if (codePtr != NULL) { - TclReleaseByteCode(codePtr); - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * 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( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv); -} - -int -TclNRTryObjCmd( - TCL_UNUSED(void *), - 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, code; - Tcl_Size dummy; - 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]; - TclNewObj(handlersObj); - 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", (void *)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", (void *)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", (void *)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", (void *)NULL); - return TCL_ERROR; - } - code = 1; - if (TclListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad prefix '%s': must be a list", - TclGetString(objv[i+1]))); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", - "EXNFORMAT", (void *)NULL); - return TCL_ERROR; - } - info[2] = objv[i+1]; - - commonHandler: - if (TclListObjLength(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; + if (!value) { 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", - (void *)NULL); - return TCL_ERROR; - } - if (!haveHandlers) { - Tcl_DecrRefCount(handlersObj); - handlersObj = NULL; - } - - /* - * Execute the body. - */ - - Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, - (void *)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( - void *data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv; - int code, objc; - Tcl_Size i, numHandlers = 0; - - handlersObj = (Tcl_Obj *)data[0]; - finallyObj = (Tcl_Obj *)data[1]; - objv = (Tcl_Obj **)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; - - TclListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); - for (i=0 ; i<numHandlers ; i++) { - Tcl_Obj *handlerBodyObj; - Tcl_Size numElems = 0; - - TclListObjGetElements(NULL, handlers[i], &numElems, &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; - Tcl_Size len1, len2, j; - - TclNewLiteralStringObj(errorCodeName, "-errorcode"); - Tcl_DictObjGet(NULL, options, errorCodeName, &errcode); - Tcl_DecrRefCount(errorCodeName); - TclListObjGetElements(NULL, info[2], &len1, &bits1); - if (TclListObjGetElements(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; - TclListObjLength(NULL, info[3], &numElems); - if (numElems> 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 (numElems> 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); + /* TIP #280. */ + result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"while\" body line %d)", interp->errorLine)); } - - /* - * 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( - void *data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv; - Tcl_Obj *finallyObj; - int finallyIndex; - - objv = (Tcl_Obj **)data[0]; - options = (Tcl_Obj *)data[1]; - handlerKindObj = (Tcl_Obj *)data[2]; - finallyIndex = PTR2INT(data[3]); - - cmdObj = objv[0]; - finallyObj = finallyIndex ? objv[finallyIndex] : 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, - finallyIndex); - } - - /* - * 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( - void *data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Obj *resultObj, *options, *cmdObj; - - resultObj = (Tcl_Obj *)data[0]; - options = (Tcl_Obj *)data[1]; - cmdObj = (Tcl_Obj *)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); - } + if (result == TCL_BREAK) { + result = TCL_OK; } - - /* - * 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); + if (result == TCL_OK) { + Tcl_ResetResult(interp); } return result; } @@ -5271,67 +4005,6 @@ TryPostFinal( /* *---------------------------------------------------------------------- * - * Tcl_WhileObjCmd -- - * - * This procedure is invoked to process the "while" Tcl command. See the - * user documentation for details on what it does. - * - * With the bytecode compiler, this procedure is only called when a - * command name is computed at runtime, and is "while" or the name to - * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_WhileObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv); -} - -int -TclNRWhileObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - ForIterData *iterPtr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "test command"); - return TCL_ERROR; - } - - /* - * 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 -- * * ??? @@ -5347,30 +4020,32 @@ TclNRWhileObjCmd( void TclListLines( - Tcl_Obj *listObj, /* Pointer to obj holding a string with list - * structure. Assumed to be valid. Assumed to - * contain n elements. */ - Tcl_Size line, /* Line the list as a whole starts on. */ - Tcl_Size n, /* #elements in lines */ - Tcl_Size *lines, /* Array of line numbers, to fill. */ - Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of + 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 = TclGetString(listObj); - const char *listHead = listStr; - Tcl_Size i, length = strlen(listStr); + 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); - Tcl_Size *clNext = (clLocPtr ? &clLocPtr->loc[0] : 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); + TclAdvanceContinuations (&line, &clNext, element - listHead); if (elems && clNext) { - TclContinuationsEnterDerived(elems[i], element-listHead, clNext); + TclContinuationsEnterDerived (elems[i], element - listHead, + clNext); } lines[i] = line; length -= (next - listStr); |