diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 1879 |
1 files changed, 1373 insertions, 506 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f6bdd3e..ee30a7a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -10,7 +10,7 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. - * Copyright (c) 2003 Donal K. Fellows. + * Copyright (c) 2003-2009 Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -19,9 +19,49 @@ #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); + +/* + * 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) */ +; /* *---------------------------------------------------------------------- @@ -92,7 +132,7 @@ Tcl_RegexpObjCmd( Tcl_RegExp regExpr; Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; Tcl_RegExpInfo info; - static const char *options[] = { + static const char *const options[] = { "-all", "-about", "-indices", "-inline", "-expanded", "-line", "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL @@ -106,20 +146,19 @@ Tcl_RegexpObjCmd( indices = 0; about = 0; cflags = TCL_REG_ADVANCED; - eflags = 0; offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { - char *name; + const char *name; int index; name = TclGetString(objv[i]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -175,7 +214,7 @@ Tcl_RegexpObjCmd( endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); + "?-option ...? exp string ?matchVar? ?subMatchVar ...?"); goto optionError; } objc -= i; @@ -187,8 +226,10 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_AppendResult(interp, "regexp match variables not allowed" - " when using -inline", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "regexp match variables not allowed when using -inline", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGEXP", + "MIX_VAR_INLINE", NULL); goto optionError; } @@ -269,7 +310,7 @@ Tcl_RegexpObjCmd( eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == (Tcl_UniChar)'\n') { + } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -316,7 +357,7 @@ Tcl_RegexpObjCmd( objc = info.nsubs + 1; if (all <= 1) { - resultPtr = Tcl_NewObj(); + TclNewObj(resultPtr); } } for (i = 0; i < objc; i++) { @@ -358,7 +399,7 @@ Tcl_RegexpObjCmd( offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { - newPtr = Tcl_NewObj(); + TclNewObj(newPtr); } } if (doinline) { @@ -369,11 +410,8 @@ Tcl_RegexpObjCmd( return TCL_ERROR; } } else { - 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); + if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, + TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } } @@ -393,7 +431,8 @@ Tcl_RegexpObjCmd( * 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; /* @@ -455,7 +494,7 @@ Tcl_RegsubObjCmd( Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static const char *options[] = { + static const char *const options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL @@ -472,14 +511,14 @@ Tcl_RegsubObjCmd( resultPtr = NULL; for (idx = 1; idx < objc; idx++) { - char *name; + const char *name; int index; name = TclGetString(objv[idx]); if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", + if (Tcl_GetIndexFromObj(interp, objv[idx], options, "option", TCL_EXACT, &index) != TCL_OK) { goto optionError; } @@ -526,7 +565,7 @@ Tcl_RegsubObjCmd( endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? exp string subSpec ?varName?"); + "?-option ...? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -800,9 +839,8 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { - if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { - Tcl_AppendResult(interp, "couldn't set variable \"", - TclGetString(objv[3]), "\"", NULL); + if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, + TCL_LEAVE_ERR_MSG) == NULL) { result = TCL_ERROR; } else { /* @@ -857,7 +895,7 @@ Tcl_RenameObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - char *oldName, *newName; + const char *oldName, *newName; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); @@ -940,6 +978,16 @@ Tcl_SourceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, dummy, objc, objv); +} + +int +TclNRSourceObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ const char *encodingName = NULL; Tcl_Obj *fileName; @@ -951,7 +999,7 @@ Tcl_SourceObjCmd( fileName = objv[objc-1]; if (objc == 4) { - static const char *options[] = { + static const char *const options[] = { "-encoding", NULL }; int index; @@ -963,7 +1011,7 @@ Tcl_SourceObjCmd( encodingName = TclGetString(objv[2]); } - return Tcl_FSEvalFileEx(interp, fileName, encodingName); + return TclNREvalFile(interp, fileName, encodingName); } /* @@ -990,10 +1038,11 @@ Tcl_SplitObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; int len; const char *splitChars; - char *stringPtr, *end; + const char *stringPtr; + const char *end; int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; @@ -1009,7 +1058,7 @@ Tcl_SplitObjCmd( stringPtr = TclGetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; - listPtr = Tcl_NewObj(); + TclNewObj(listPtr); if (stringLen == 0) { /* @@ -1032,13 +1081,10 @@ Tcl_SplitObjCmd( Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { - len = TclUtfToUniChar(stringPtr, &ch); - - /* - * Assume Tcl_UniChar is an integral type... - */ + int ucs4; - hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); + len = TclUtfToUCS4(stringPtr, &ucs4); + hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ucs4), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); @@ -1046,9 +1092,9 @@ Tcl_SplitObjCmd( * Don't need to fiddle with refcount... */ - Tcl_SetHashValue(hPtr, (ClientData) objPtr); + Tcl_SetHashValue(hPtr, objPtr); } else { - objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); + objPtr = Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } @@ -1071,10 +1117,9 @@ Tcl_SplitObjCmd( TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { - char *element; - const char *p, *splitEnd; + const char *element, *p, *splitEnd; int splitLen; - Tcl_UniChar splitChar; + Tcl_UniChar splitChar = 0; /* * Normal case: split on any of a given set of characters. Discard @@ -1109,7 +1154,8 @@ Tcl_SplitObjCmd( * StringFirstCmd -- * * This procedure is invoked to process the "string first" 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. @@ -1127,8 +1173,8 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring1, *ustring2; - int match, start, length1, length2; + Tcl_UniChar *needleStr, *haystackStr; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1137,15 +1183,15 @@ StringFirstCmd( } /* - * We are searching string2 for the sequence string1. + * We are searching haystackStr for the sequence needleStr. */ match = -1; start = 0; - length2 = -1; + haystackLen = -1; - ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); if (objc == 4) { /* @@ -1153,7 +1199,8 @@ StringFirstCmd( * point in the string before we think about a match. */ - if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } @@ -1161,14 +1208,14 @@ StringFirstCmd( * Reread to prevent shimmering problems. */ - ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (start >= length2) { + if (start >= haystackLen) { goto str_first_done; } else if (start > 0) { - ustring2 += start; - length2 -= start; + haystackStr += start; + haystackLen -= start; } else if (start < 0) { /* * Invalid start index mapped to string start; Bug #423581 @@ -1183,18 +1230,18 @@ StringFirstCmd( * cannot be contained in there so we can avoid searching. [Bug 2960021] */ - if (length1 > 0 && length1 <= length2) { - register Tcl_UniChar *p, *end; + if (needleLen > 0 && needleLen <= haystackLen) { + Tcl_UniChar *p, *end; - end = ustring2 + length2 - length1 + 1; - for (p = ustring2; p < end; p++) { + end = haystackStr + haystackLen - needleLen + 1; + for (p = haystackStr; p < end; p++) { /* * Scan forward to find the first character. */ - if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, - (unsigned long) length1) == 0)) { - match = p - ustring2; + if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, + (unsigned long) needleLen) == 0)) { + match = p - haystackStr; break; } } @@ -1220,7 +1267,8 @@ StringFirstCmd( * StringLastCmd -- * * This procedure is invoked to process the "string last" 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. @@ -1238,8 +1286,8 @@ StringLastCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring1, *ustring2, *p; - int match, start, length1, length2; + Tcl_UniChar *needleStr, *haystackStr, *p; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1248,15 +1296,15 @@ StringLastCmd( } /* - * We are searching string2 for the sequence string1. + * We are searching haystackString for the sequence needleString. */ match = -1; start = 0; - length2 = -1; + haystackLen = -1; - ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); if (objc == 4) { /* @@ -1264,7 +1312,8 @@ StringLastCmd( * range to that char index in the string */ - if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } @@ -1272,18 +1321,18 @@ StringLastCmd( * Reread to prevent shimmering problems. */ - ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); + needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); + haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); if (start < 0) { goto str_last_done; - } else if (start < length2) { - p = ustring2 + start + 1 - length1; + } else if (start < haystackLen) { + p = haystackStr + start + 1 - needleLen; } else { - p = ustring2 + length2 - length1; + p = haystackStr + haystackLen - needleLen; } } else { - p = ustring2 + length2 - length1; + p = haystackStr + haystackLen - needleLen; } /* @@ -1291,15 +1340,15 @@ StringLastCmd( * cannot be contained in there so we can avoid searching. [Bug 2960021] */ - if (length1 > 0 && length1 <= length2) { - for (; p >= ustring2; p--) { + if (needleLen > 0 && needleLen <= haystackLen) { + for (; p >= haystackStr; p--) { /* * Scan backwards to find the first character. */ - if ((*p == *ustring1) && !memcmp(ustring1, p, - sizeof(Tcl_UniChar) * (size_t)length1)) { - match = p - ustring2; + if ((*p == *needleStr) && !memcmp(needleStr, p, + sizeof(Tcl_UniChar) * (size_t)needleLen)) { + match = p - haystackStr; break; } } @@ -1343,38 +1392,30 @@ StringIndexCmd( } /* - * 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. + * Get the char length to calulate what 'end' means. */ - if (TclIsPureByteArray(objv[1])) { - const unsigned char *string = - Tcl_GetByteArrayFromObj(objv[1], &length); + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { + return TCL_ERROR; + } + + if ((index >= 0) && (index < length)) { + int ch = TclGetUCS4(objv[1], index); - 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 { /* - * Get Unicode char length to calulate what 'end' means. + * If we have a ByteArray object, we're careful to generate a new + * bytearray for a result. */ - length = Tcl_GetCharLength(objv[1]); + if (TclIsPureByteArray(objv[1])) { + unsigned char uch = UCHAR(ch); - 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; + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); + } else { + char buf[8] = ""; - ch = Tcl_GetUniChar(objv[1], index); - length = Tcl_UniCharToUtf(ch, buf); + length = TclUCS4ToUtf(ch, buf); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } @@ -1407,28 +1448,28 @@ StringIsCmd( 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 *isClasses[] = { + static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "false", - "graph", "integer", "list", "lower", - "print", "punct", "space", "true", - "upper", "wideinteger", "wordchar", "xdigit", - NULL + "boolean", "digit", "double", "entier", + "false", "graph", "integer", "list", + "lower", "print", "punct", "space", + "true", "upper", "wideinteger", "wordchar", + "xdigit", NULL }; enum isClasses { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_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 + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, + STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, + STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, + STR_IS_XDIGIT }; - static const char *isOptions[] = { + static const char *const isOptions[] = { "-strict", "-failindex", NULL }; enum isOptions { @@ -1495,7 +1536,8 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + if ((objPtr->typePtr != &tclBooleanType) + && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { @@ -1518,7 +1560,7 @@ StringIsCmd( case STR_IS_DOUBLE: { if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || -#ifndef NO_WIDE_TYPE +#ifndef TCL_WIDE_INT_IS_LONG (objPtr->typePtr == &tclWideIntType) || #endif (objPtr->typePtr == &tclBignumType)) { @@ -1541,7 +1583,6 @@ StringIsCmd( if (stop < end) { result = 0; TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } } break; @@ -1554,8 +1595,53 @@ StringIsCmd( break; } goto failedIntParse; + case STR_IS_ENTIER: + if ((objPtr->typePtr == &tclIntType) || +#ifndef TCL_WIDE_INT_IS_LONG + (objPtr->typePtr == &tclWideIntType) || +#endif + (objPtr->typePtr == &tclBignumType)) { + break; + } + string1 = TclGetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, + (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { + if (stop == end) { + /* + * 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; + TclFreeIntRep(objPtr); + } + } else { + /* + * No prefix is a valid integer. Fail at beginning. + */ + + result = 0; + failat = 0; + } + break; case STR_IS_WIDE: - if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { + if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) { break; } @@ -1598,7 +1684,6 @@ StringIsCmd( failat = stop - string1; TclFreeIntRep(objPtr); - objPtr->typePtr = NULL; } } else { /* @@ -1627,7 +1712,7 @@ StringIsCmd( const char *elemStart, *nextElem; int lenRemain, elemSize; - register const char *p; + const char *p; string1 = TclGetStringFromObj(objPtr, &length1); end = string1 + length1; @@ -1693,8 +1778,10 @@ StringIsCmd( } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { - length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { + int ucs4; + + length2 = TclUtfToUCS4(string1, &ucs4); + if (!chcomp(ucs4)) { result = 0; break; } @@ -1770,11 +1857,13 @@ StringMapCmd( const char *string = TclGetStringFromObj(objv[1], &length2); if ((length2 > 1) && - strncmp(string, "-nocase", (size_t) length2) == 0) { + strncmp(string, "-nocase", length2) == 0) { nocase = 1; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -1811,8 +1900,7 @@ StringMapCmd( * adapt this code... */ - mapElemv = (Tcl_Obj **) - TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); + mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); for (i=2 ; i<mapElemc ; i+=2) { @@ -1838,6 +1926,8 @@ StringMapCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("char map list unbalanced", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", + "UNBALANCED", NULL); return TCL_ERROR; } } @@ -1921,12 +2011,10 @@ StringMapCmd( * case. */ - mapStrings = (Tcl_UniChar **) TclStackAlloc(interp, - mapElemc * 2 * sizeof(Tcl_UniChar *)); - mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); + mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); + mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = (Tcl_UniChar *) TclStackAlloc(interp, - mapElemc * sizeof(Tcl_UniChar)); + u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -1947,7 +2035,7 @@ StringMapCmd( (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || - !strCmpFn(ustring2, ustring1, (unsigned) length2))) { + !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. @@ -2036,11 +2124,13 @@ StringMatchCmd( const char *string = TclGetStringFromObj(objv[1], &length); if ((length > 1) && - strncmp(string, "-nocase", (size_t) length) == 0) { + strncmp(string, "-nocase", length) == 0) { nocase = TCL_MATCH_NOCASE; } else { - Tcl_AppendResult(interp, "bad option \"", string, - "\": must be -nocase", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, NULL); return TCL_ERROR; } } @@ -2074,7 +2164,6 @@ StringRangeCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const unsigned char *string; int length, first, last; if (objc != 4) { @@ -2083,22 +2172,11 @@ StringRangeCmd( } /* - * 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. + * Get the length in actual characters; Then reduce it by one because + * 'end' refers to the last character, not one past it. */ - if (TclIsPureByteArray(objv[1])) { - string = Tcl_GetByteArrayFromObj(objv[1], &length); - length--; - } else { - /* - * Get the length in actual characters. - */ - - string = NULL; - length = Tcl_GetCharLength(objv[1]) - 1; - } + length = Tcl_GetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { @@ -2112,17 +2190,7 @@ StringRangeCmd( 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)); - } + Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); } return TCL_OK; } @@ -2191,9 +2259,11 @@ StringReptCmd( * We need to keep 2 <= length2 <= INT_MAX. */ - if (count > (INT_MAX / length1)) { + if (count > INT_MAX/length1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); + "result exceeds max size for a Tcl value (%d bytes)", + INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } length2 = length1 * count; @@ -2202,7 +2272,7 @@ StringReptCmd( * Include space for the NUL. */ - string2 = attemptckalloc((unsigned) length2 + 1); + string2 = attemptckalloc(length2 + 1); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message @@ -2214,10 +2284,11 @@ StringReptCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow, out of memory allocating %u bytes", length2 + 1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); + memcpy(string2 + (length1 * index), string1, length1); } string2[length2] = '\0'; @@ -2295,6 +2366,11 @@ StringRplcCmd( } else { Tcl_Obj *resultPtr; + /* + * We are re-fetching in case the string argument is same value as + * an index argument, and shimmering cost us our ustring. + */ + ustring = Tcl_GetUnicodeFromObj(objv[1], &length); end = length-1; @@ -2345,7 +2421,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + Tcl_SetObjResult(interp, TclStringReverse(objv[1])); return TCL_OK; } @@ -2375,7 +2451,7 @@ StringStartCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *string; int cur, index, length, numChars; @@ -2446,7 +2522,7 @@ StringEndCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar ch; + Tcl_UniChar ch = 0; const char *p, *end, *string; int cur, index, length, numChars; @@ -2514,10 +2590,8 @@ StringEqualCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - 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; + const char *string2; + int length2, i, match, nocase = 0, reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: @@ -2528,20 +2602,23 @@ StringEqualCmd( for (i = 1; i < objc-2; i++) { string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { + if ((length2 > 1) && !strncmp(string2, "-nocase", length2)) { nocase = 1; } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { + && !strncmp(string2, "-length", length2)) { if (i+1 >= objc-2) { goto str_cmp_args; } - ++i; + i++; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string2)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string2, NULL); return TCL_ERROR; } } @@ -2552,80 +2629,7 @@ StringEqualCmd( */ objv += objc-2; - - 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; - } - } - + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } @@ -2661,56 +2665,59 @@ StringCmpCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - 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; + int match, nocase, reqlength, status; - if (objc < 3 || objc > 6) { - str_cmp_args: - Tcl_WrongNumArgs(interp, 1, objv, - "?-nocase? ?-length int? string1 string2"); - return TCL_ERROR; + status = TclStringCmpOpts(interp, objc, objv, &nocase, &reqlength); + if (status != TCL_OK) { + return status; } - for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { - nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", (size_t)length2)) { - if (i+1 >= objc-2) { - goto str_cmp_args; - } - ++i; - if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "bad option \"", string2, - "\": must be -nocase or -length", NULL); - return TCL_ERROR; - } - } - - /* - * From now on, we only access the two objects at the end of the argument - * array. - */ - objv += objc-2; + match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclStringCmp -- + * + * This is the core of Tcl's string comparison. It only handles byte + * arrays, UNICODE strings and UTF-8 strings correctly. + * + * Results: + * -1 if value1Ptr is less than value2Ptr, 0 if they are equal, or 1 if + * value1Ptr is greater. + * + * Side effects: + * May cause string representations of objects to be allocated. + * + *---------------------------------------------------------------------- + */ - if ((reqlength == 0) || (objv[0] == objv[1])) { +int +TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length; -1 to compare whole + * strings */ +{ + const char *s1, *s2; + int empty, length, match, s1len, s2len; + memCmpFn_t memCmpFn; + + if ((reqlength == 0) || (value1Ptr == value2Ptr)) { /* - * Always match at 0 chars of if it is the same obj. + * Always match at 0 chars or if it is the same obj. */ - - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); - return TCL_OK; + return 0; } - if (!nocase && TclIsPureByteArray(objv[0]) && - TclIsPureByteArray(objv[1])) { + if (!nocase && TclIsPureByteArray(value1Ptr) + && TclIsPureByteArray(value2Ptr)) { /* * Use binary versions of comparisons since that won't cause undue * type conversions and it is much faster. Only do this if we're @@ -2718,41 +2725,113 @@ StringCmpCmd( * 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)) { + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if ((value1Ptr->typePtr == &tclStringType) + && (value2Ptr->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. + * type. If the char length == byte length, we can do a memcmp. 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); + if (nocase) { + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + } else { + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == value1Ptr->length) + && (value1Ptr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { + s1 = value1Ptr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; + } else { + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif /* WORDS_BIGENDIAN */ + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) 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. + * Get the string representations, being careful in case we have + * special empty string objects about. */ - string1 = (char *) TclGetStringFromObj(objv[0], &length1); - string2 = (char *) TclGetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; + empty = TclCheckEmptyString(value1Ptr); + if (empty > 0) { + switch (TclCheckEmptyString(value2Ptr)) { + case -1: + s1 = ""; + s1len = 0; + s2 = TclGetStringFromObj(value2Ptr, &s2len); + break; + case 0: + return -1; + default: /* avoid warn: `s2` may be used uninitialized */ + return 0; + } + } else if (TclCheckEmptyString(value2Ptr) > 0) { + switch (empty) { + case -1: + s2 = ""; + s2len = 0; + s1 = TclGetStringFromObj(value1Ptr, &s1len); + break; + case 0: + return 1; + default: /* avoid warn: `s1` may be used uninitialized */ + return 0; + } + } else { + s1 = TclGetStringFromObj(value1Ptr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + } + + if (!nocase && checkEq) { + /* + * When we have equal-length we can check only for (in)equality. + * We can use memcmp() in all (n)eq cases because we don't need to + * worry about lexical LE/BE variance. + */ + memCmpFn = memcmp; } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + /* + * 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. + */ + + if ((reqlength < 0) && !nocase) { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } else { + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = (memCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } } } - length = (length1 < length2) ? length1 : length2; + length = (s1len < s2len) ? s1len : s2len; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { @@ -2764,13 +2843,115 @@ StringCmpCmd( reqlength = length + 1; } - match = strCmpFn(string1, string2, (unsigned) length); + if (checkEq && (s1len != s2len)) { + match = 1; /* This will be reversed below. */ + } else { + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + match = memCmpFn(s1, s2, length); + } if ((match == 0) && (reqlength > length)) { - match = length1 - length2; + match = s1len - s2len; } + return (match > 0) ? 1 : (match < 0) ? -1 : 0; +} + +int TclStringCmpOpts( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[], /* Argument objects. */ + int *nocase, + int *reqlength) +{ + int i, length; + const char *string; + + *reqlength = -1; + *nocase = 0; + if (objc < 3 || objc > 6) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 1; i < objc-2; i++) { + string = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string, "-nocase", length)) { + *nocase = 1; + } else if ((length > 1) + && !strncmp(string, "-length", length)) { + if (i+1 >= objc-2) { + goto str_cmp_args; + } + i++; + if (TclGetIntFromObj(interp, objv[i], reqlength) != TCL_OK) { + return TCL_ERROR; + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": must be -nocase or -length", + string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", + string, 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( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i; + Tcl_Obj *objResultPtr; + + if (objc < 2) { + /* + * If there are no args, the result is an empty object. + * Just leave the preset empty interp result. + */ + return TCL_OK; + } + if (objc == 2) { + /* + * Other trivial case, single arg, just return it. + */ + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + objResultPtr = objv[1]; + if (Tcl_IsShared(objResultPtr)) { + objResultPtr = Tcl_DuplicateObj(objResultPtr); + } + for(i = 2;i < objc;i++) { + Tcl_AppendObjToObj(objResultPtr, objv[i]); + } + Tcl_SetObjResult(interp, objResultPtr); - Tcl_SetObjResult(interp, - Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); return TCL_OK; } @@ -2837,25 +3018,12 @@ StringLenCmd( 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; } - /* - * 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)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } @@ -2885,7 +3053,8 @@ StringLowerCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int length1, length2; - char *string1, *string2; + const char *string1; + char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -2969,7 +3138,8 @@ StringUpperCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int length1, length2; - char *string1, *string2; + const char *string1; + char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3053,7 +3223,8 @@ StringTitleCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int length1, length2; - char *string1, *string2; + const char *string1; + char *string2; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); @@ -3142,8 +3313,8 @@ StringTrimCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = " \t\n\r"; - length2 = strlen(string2); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3189,8 +3360,8 @@ StringTrimLCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = " \t\n\r"; - length2 = strlen(string2); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3235,8 +3406,8 @@ StringTrimRCmd( if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = " \t\n\r"; - length2 = strlen(string2); + string2 = tclDefaultTrimSet; + length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3277,29 +3448,30 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"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} + {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"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}, + {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, + {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, + {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, + {"map", StringMapCmd, TclCompileStringMapCmd, NULL, NULL, 0}, + {"match", StringMatchCmd, TclCompileStringMatchCmd, NULL, NULL, 0}, + {"range", StringRangeCmd, TclCompileStringRangeCmd, NULL, NULL, 0}, + {"repeat", StringReptCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"replace", StringRplcCmd, TclCompileStringReplaceCmd, NULL, NULL, 0}, + {"reverse", StringRevCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tolower", StringLowerCmd, TclCompileStringToLowerCmd, NULL, NULL, 0}, + {"toupper", StringUpperCmd, TclCompileStringToUpperCmd, NULL, NULL, 0}, + {"totitle", StringTitleCmd, TclCompileStringToTitleCmd, NULL, NULL, 0}, + {"trim", StringTrimCmd, TclCompileStringTrimCmd, NULL, NULL, 0}, + {"trimleft", StringTrimLCmd, TclCompileStringTrimLCmd, NULL, NULL, 0}, + {"trimright", StringTrimRCmd, TclCompileStringTrimRCmd, NULL, NULL, 0}, + {"wordend", StringEndCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"wordstart", StringStartCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "string", stringImplMap); @@ -3324,30 +3496,24 @@ TclInitStringCmd( */ int -Tcl_SubstObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ +TclSubstOptions( + Tcl_Interp *interp, + int numOpts, + Tcl_Obj *const opts[], + int *flagPtr) { - static const char *substOptions[] = { + static const char *const substOptions[] = { "-nobackslashes", "-nocommands", "-novariables", NULL }; - enum substOptions { + enum { SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS }; - Tcl_Obj *resultPtr; - int flags, i; + int i, flags = TCL_SUBST_ALL; - /* - * Parse command-line options. - */ - - flags = TCL_SUBST_ALL; - for (i = 1; i < (objc-1); i++) { + for (i = 0; i < numOpts; i++) { int optionIndex; - if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + if (Tcl_GetIndexFromObj(interp, opts[i], substOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3365,23 +3531,39 @@ Tcl_SubstObjCmd( Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - if (i != objc-1) { + *flagPtr = flags; + return TCL_OK; +} + +int +Tcl_SubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, dummy, objc, objv); +} + +int +TclNRSubstObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int flags; + + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-nobackslashes? ?-nocommands? ?-novariables? string"); return TCL_ERROR; } - /* - * Perform the substitution. - */ - - resultPtr = Tcl_SubstObj(interp, objv[i], flags); - - if (resultPtr == NULL) { + if (TclSubstOptions(interp, objc-2, objv+1, &flags) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + return Tcl_NRSubstObj(interp, objv[objc-1], flags); } /* @@ -3408,9 +3590,18 @@ Tcl_SwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved; + return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv); +} +int +TclNRSwitchObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i,j, index, mode, foundmode, splitObjs, numMatchesSaved; int noCase, patternLength; - char *pattern; + const char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *const *savedObjv = objv; Tcl_RegExp regExpr = NULL; @@ -3426,7 +3617,7 @@ Tcl_SwitchObjCmd( * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ - static const char *options[] = { + static const char *const options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL }; @@ -3474,15 +3665,16 @@ Tcl_SwitchObjCmd( * Mode already set via -exact, -glob, or -regexp. */ - Tcl_AppendResult(interp, "bad option \"", - TclGetString(objv[i]), "\": ", options[mode], - " option already found", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad option \"%s\": %s option already found", + TclGetString(objv[i]), options[mode])); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "DOUBLEOPT", NULL); return TCL_ERROR; - } else { - foundmode = 1; - mode = index; - break; } + foundmode = 1; + mode = index; + break; /* * Check for TIP#75 options specifying the variables to write @@ -3492,8 +3684,11 @@ Tcl_SwitchObjCmd( case OPT_INDEXV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-indexvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3502,8 +3697,11 @@ Tcl_SwitchObjCmd( case OPT_MATCHV: i++; if (i >= objc-2) { - Tcl_AppendResult(interp, "missing variable name argument to ", - "-matchvar", " option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing variable name argument to %s option", + "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "NOVAR", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3515,17 +3713,21 @@ Tcl_SwitchObjCmd( finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?switches? string pattern body ... ?default body?"); + "?-option ...? string ?pattern body ...? ?default body?"); return TCL_ERROR; } if (indexVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-indexvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-indexvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } if (matchVarObj != NULL && mode != OPT_REGEXP) { - Tcl_AppendResult(interp, - "-matchvar option requires -regexp option", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s option requires -regexp option", "-matchvar")); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "MODERESTRICTION", NULL); return TCL_ERROR; } @@ -3546,8 +3748,8 @@ Tcl_SwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - blist = objv[0]; + blist = objv[0]; if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } @@ -3558,7 +3760,7 @@ Tcl_SwitchObjCmd( if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?switches? string {pattern body ... ?default body?}"); + "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } objv = listv; @@ -3572,7 +3774,10 @@ Tcl_SwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra switch pattern with no body", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + NULL); /* * Check if this can be due to a badly placed comment in the switch @@ -3585,10 +3790,12 @@ Tcl_SwitchObjCmd( if (splitObjs) { for (i=0 ; i<objc ; i+=2) { if (TclGetString(objv[i])[0] == '#') { - Tcl_AppendResult(interp, ", this may be due to a " - "comment incorrectly placed outside of a " - "switch body - see the \"switch\" " - "documentation", NULL); + Tcl_AppendToObj(Tcl_GetObjResult(interp), + ", this may be due to a comment incorrectly" + " placed outside of a switch body - see the" + " \"switch\" documentation", -1); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", + "BADARM", "COMMENT?", NULL); break; } } @@ -3603,9 +3810,11 @@ Tcl_SwitchObjCmd( */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "no body specified for pattern \"", - TclGetString(objv[objc-2]), "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no body specified for pattern \"%s\"", + TclGetString(objv[objc-2]))); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", + "FALLTHROUGH", NULL); return TCL_ERROR; } @@ -3644,36 +3853,35 @@ Tcl_SwitchObjCmd( } } goto matchFound; - } else { - switch (mode) { - case OPT_EXACT: - if (strCmpFn(TclGetString(stringObj), pattern) == 0) { - goto matchFound; - } - break; - case OPT_GLOB: - if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, - noCase)) { - goto matchFound; - } - break; - case OPT_REGEXP: - regExpr = Tcl_GetRegExpFromObj(interp, objv[i], - TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); - if (regExpr == NULL) { - return TCL_ERROR; - } else { - int matched = Tcl_RegExpExecObj(interp, regExpr, - stringObj, 0, numMatchesSaved, 0); + } - if (matched < 0) { - return TCL_ERROR; - } else if (matched) { - goto matchFoundRegexp; - } + switch (mode) { + case OPT_EXACT: + if (strCmpFn(TclGetString(stringObj), pattern) == 0) { + goto matchFound; + } + break; + case OPT_GLOB: + if (Tcl_StringCaseMatch(TclGetString(stringObj),pattern,noCase)) { + goto matchFound; + } + break; + case OPT_REGEXP: + regExpr = Tcl_GetRegExpFromObj(interp, objv[i], + TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); + if (regExpr == NULL) { + return TCL_ERROR; + } else { + int matched = Tcl_RegExpExecObj(interp, regExpr, stringObj, 0, + numMatchesSaved, 0); + + if (matched < 0) { + return TCL_ERROR; + } else if (matched) { + goto matchFoundRegexp; } - break; } + break; } } return TCL_OK; @@ -3707,7 +3915,8 @@ Tcl_SwitchObjCmd( rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { - rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + TclNewIntObj(rangeObjAry[1], -1); + rangeObjAry[0] = rangeObjAry[1]; } /* @@ -3769,7 +3978,7 @@ Tcl_SwitchObjCmd( */ matchFound: - ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *iPtr->cmdFramePtr; if (splitObjs) { @@ -3784,7 +3993,7 @@ Tcl_SwitchObjCmd( 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); @@ -3799,7 +4008,7 @@ Tcl_SwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3813,7 +4022,7 @@ Tcl_SwitchObjCmd( int k; - ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); + ctxPtr->line = ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3839,9 +4048,31 @@ Tcl_SwitchObjCmd( * TIP #280: Make invoking context available to switch branch. */ - result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); + Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, + INT2PTR(pc), (ClientData) pattern); + return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); +} + +static int +SwitchPostProc( + ClientData data[], /* Data passed from Tcl_NRAddCallback above */ + Tcl_Interp *interp, /* Tcl interpreter */ + int result) /* Result to return*/ +{ + /* Unpack the preserved data */ + + int splitObjs = PTR2INT(data[0]); + CmdFrame *ctxPtr = data[1]; + int pc = PTR2INT(data[2]); + const char *pattern = data[3]; + int patternLength = strlen(pattern); + + /* + * Clean up TIP 280 context information + */ + if (splitObjs) { - ckfree((char *) ctxPtr->line); + ckfree(ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -3862,7 +4093,7 @@ Tcl_SwitchObjCmd( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", (overflow ? limit : patternLength), pattern, - (overflow ? "..." : ""), interp->errorLine)); + (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } TclStackFree(interp, ctxPtr); return result; @@ -3871,6 +4102,69 @@ Tcl_SwitchObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_ThrowObjCmd -- + * + * This procedure is invoked to process the "throw" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_ThrowObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *options; + int len; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "type message"); + return TCL_ERROR; + } + + /* + * The type must be a list of at least length 1. + */ + + if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) { + return TCL_ERROR; + } else if (len < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "type must be non-empty list", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION", + NULL); + return TCL_ERROR; + } + + /* + * Now prepare the result options dictionary. We use the list API as it is + * slightly more convenient. + */ + + TclNewLiteralStringObj(options, "-code error -level 0 -errorcode"); + Tcl_ListObjAppendElement(NULL, options, objv[1]); + + /* + * We're ready to go. Fire things into the low-level result machinery. + */ + + Tcl_SetObjResult(interp, objv[2]); + return Tcl_SetReturnOptions(interp, options); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_TimeObjCmd -- * * This object-based procedure is invoked to process the "time" Tcl @@ -3892,9 +4186,9 @@ Tcl_TimeObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Tcl_Obj *objPtr; + Tcl_Obj *objPtr; Tcl_Obj *objs[4]; - register int i, result; + int i, result; int count; double totalMicroSec; #ifndef TCL_WIDE_CLICKS @@ -3923,7 +4217,7 @@ Tcl_TimeObjCmd( start = TclpGetWideClicks(); #endif while (i-- > 0) { - result = Tcl_EvalObjEx(interp, objPtr, 0); + result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); if (result != TCL_OK) { return result; } @@ -3993,8 +4287,8 @@ Tcl_TimeRateObjCmd( static double measureOverhead = 0; /* global measure-overhead */ double overhead = -1; /* given measure-overhead */ - register Tcl_Obj *objPtr; - register int result, i; + Tcl_Obj *objPtr; + int result, i; Tcl_Obj *calibrate = NULL, *direct = NULL; TclWideMUInt count = 0; /* Holds repetition count */ Tcl_WideInt maxms = WIDE_MIN; @@ -4008,7 +4302,7 @@ Tcl_TimeRateObjCmd( * zero (i.e., never < 1) */ unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid * growth of execution time. */ - register Tcl_WideInt start, middle, stop; + Tcl_WideInt start, middle, stop; #ifndef TCL_WIDE_CLICKS Tcl_Time now; #endif /* !TCL_WIDE_CLICKS */ @@ -4018,6 +4312,7 @@ Tcl_TimeRateObjCmd( enum options { TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST }; + NRE_callback *rootPtr; ByteCode *codePtr = NULL; for (i = 1; i < objc - 1; i++) { @@ -4243,13 +4538,15 @@ Tcl_TimeRateObjCmd( 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 = TclExecuteByteCode(interp, codePtr); + result = TclNRExecuteByteCode(interp, codePtr); + result = TclNRRunCallbacks(interp, result, rootPtr); } else { /* eval */ result = TclEvalObjEx(interp, objPtr, 0, NULL, 0); } @@ -4267,6 +4564,7 @@ Tcl_TimeRateObjCmd( */ threshold = 1; maxcnt = 0; + /* FALLTHRU */ case TCL_CONTINUE: result = TCL_OK; break; @@ -4317,9 +4615,11 @@ Tcl_TimeRateObjCmd( threshold = (middle - start) / count; if (threshold > maxIterTm) { maxIterTm = threshold; + /* * Iterations seem to be longer. */ + if (threshold > maxIterTm * 2) { factor *= 2; if (factor > 50) { @@ -4506,6 +4806,578 @@ Tcl_TimeRateObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_TryObjCmd, TclNRTryObjCmd -- + * + * This procedure is invoked to process the "try" Tcl command. See the + * user documentation (or TIP #329) for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_TryObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv); +} + +int +TclNRTryObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL; + int i, bodyShared, haveHandlers, dummy, code; + static const char *const handlerNames[] = { + "finally", "on", "trap", NULL + }; + enum Handlers { + TryFinally, TryOn, TryTrap + }; + + /* + * Parse the arguments. The handlers are passed to subsequent callbacks as + * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix, + * bindVariables, script), and the finally script is just passed as it is. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, + "body ?handler ...? ?finally script?"); + return TCL_ERROR; + } + bodyObj = objv[1]; + 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", NULL); + return TCL_ERROR; + } else if (i == objc-1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to finally clause: must be" + " \"... finally script\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", + "ARGUMENT", NULL); + return TCL_ERROR; + } + finallyObj = objv[++i]; + break; + + case TryOn: /* on code variableList script */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to on clause: must be \"... on code" + " variableList script\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON", + "ARGUMENT", NULL); + return TCL_ERROR; + } + if (TclGetCompletionCodeFromObj(interp, objv[i+1], + &code) != TCL_OK) { + Tcl_DecrRefCount(handlersObj); + return TCL_ERROR; + } + info[2] = NULL; + goto commonHandler; + + case TryTrap: /* trap pattern variableList script */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong # args to trap clause: " + "must be \"... trap pattern variableList script\"", + -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "ARGUMENT", NULL); + return TCL_ERROR; + } + code = 1; + if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad prefix '%s': must be a list", + Tcl_GetString(objv[i+1]))); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP", + "EXNFORMAT", NULL); + return TCL_ERROR; + } + info[2] = objv[i+1]; + + commonHandler: + if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { + Tcl_DecrRefCount(handlersObj); + return TCL_ERROR; + } + + info[0] = objv[i]; /* type */ + TclNewIntObj(info[1], code); /* returnCode */ + if (info[2] == NULL) { /* errorCodePrefix */ + TclNewObj(info[2]); + } + info[3] = objv[i+2]; /* bindVariables */ + info[4] = objv[i+3]; /* script */ + + bodyShared = !strcmp(TclGetString(objv[i+3]), "-"); + Tcl_ListObjAppendElement(NULL, handlersObj, + Tcl_NewListObj(5, info)); + haveHandlers = 1; + i += 3; + break; + } + } + if (bodyShared) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "last non-finally clause must not have a body of \"-\"", -1)); + Tcl_DecrRefCount(handlersObj); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH", + NULL); + return TCL_ERROR; + } + if (!haveHandlers) { + Tcl_DecrRefCount(handlersObj); + handlersObj = NULL; + } + + /* + * Execute the body. + */ + + Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj, + (ClientData)objv, INT2PTR(objc)); + return TclNREvalObjEx(interp, bodyObj, 0, + ((Interp *) interp)->cmdFramePtr, 1); +} + +/* + *---------------------------------------------------------------------- + * + * During -- + * + * This helper function patches together the updates to the interpreter's + * return options that are needed when things fail during the processing + * of a handler or finally script for the [try] command. + * + * Returns: + * The new option dictionary. + * + *---------------------------------------------------------------------- + */ + +static inline Tcl_Obj * +During( + Tcl_Interp *interp, + int resultCode, /* The result code from the just-evaluated + * script. */ + Tcl_Obj *oldOptions, /* The old option dictionary. */ + Tcl_Obj *errorInfo) /* An object to append to the errorinfo and + * release, or NULL if nothing is to be added. + * Designed to be used with Tcl_ObjPrintf. */ +{ + Tcl_Obj *during, *options; + + if (errorInfo != NULL) { + Tcl_AppendObjToErrorInfo(interp, errorInfo); + } + options = Tcl_GetReturnOptions(interp, resultCode); + TclNewLiteralStringObj(during, "-during"); + Tcl_IncrRefCount(during); + Tcl_DictObjPut(interp, options, during, oldOptions); + Tcl_DecrRefCount(during); + Tcl_IncrRefCount(options); + Tcl_DecrRefCount(oldOptions); + return options; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostBody -- + * + * Callback to handle the outcome of the execution of the body of a 'try' + * command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostBody( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv; + int i, dummy, code, objc; + int numHandlers = 0; + + handlersObj = data[0]; + finallyObj = data[1]; + objv = data[2]; + objc = PTR2INT(data[3]); + + cmdObj = objv[0]; + + /* + * Check for limits/rewinding, which override normal trapping behaviour. + */ + + if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body line %d)", TclGetString(cmdObj), + Tcl_GetErrorLine(interp))); + if (handlersObj != NULL) { + Tcl_DecrRefCount(handlersObj); + } + return TCL_ERROR; + } + + /* + * Basic processing of the outcome of the script, including adding of + * errorinfo trace. + */ + + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%s\" body line %d)", TclGetString(cmdObj), + Tcl_GetErrorLine(interp))); + } + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + Tcl_ResetResult(interp); + + /* + * Handle the results. + */ + + if (handlersObj != NULL) { + int found = 0; + Tcl_Obj **handlers, **info; + + Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers); + for (i=0 ; i<numHandlers ; i++) { + Tcl_Obj *handlerBodyObj; + + Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info); + if (!found) { + Tcl_GetIntFromObj(NULL, info[1], &code); + if (code != result) { + continue; + } + + /* + * When processing an error, we must also perform list-prefix + * matching of the errorcode list. However, if this was an + * 'on' handler, the list that we are matching against will be + * empty. + */ + + if (code == TCL_ERROR) { + Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2; + int len1, len2, j; + + TclNewLiteralStringObj(errorCodeName, "-errorcode"); + Tcl_DictObjGet(NULL, options, errorCodeName, &errcode); + Tcl_DecrRefCount(errorCodeName); + Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1); + if (Tcl_ListObjGetElements(NULL, errcode, &len2, + &bits2) != TCL_OK) { + continue; + } + if (len2 < len1) { + continue; + } + for (j=0 ; j<len1 ; j++) { + if (strcmp(TclGetString(bits1[j]), + TclGetString(bits2[j])) != 0) { + /* + * Really want 'continue outerloop;', but C does + * not give us that. + */ + + goto didNotMatch; + } + } + } + + found = 1; + } + + /* + * Now we need to scan forward over "-" bodies. Note that we've + * already checked that the last body is not a "-", so this search + * will terminate successfully. + */ + + if (!strcmp(TclGetString(info[4]), "-")) { + continue; + } + + /* + * Bind the variables. We already know this is a list of variable + * names, but it might be empty. + */ + + Tcl_ResetResult(interp); + result = TCL_ERROR; + Tcl_ListObjLength(NULL, info[3], &dummy); + if (dummy > 0) { + Tcl_Obj *varName; + + Tcl_ListObjIndex(NULL, info[3], 0, &varName); + if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj, + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(resultObj); + goto handlerFailed; + } + Tcl_DecrRefCount(resultObj); + if (dummy > 1) { + Tcl_ListObjIndex(NULL, info[3], 1, &varName); + if (Tcl_ObjSetVar2(interp, varName, NULL, options, + TCL_LEAVE_ERR_MSG) == NULL) { + goto handlerFailed; + } + } + } else { + /* + * Dispose of the result to prevent a memleak. [Bug 2910044] + */ + + Tcl_DecrRefCount(resultObj); + } + + /* + * Evaluate the handler body and process the outcome. Note that we + * need to keep the kind of handler for debugging purposes, and in + * any case anything we want from info[] must be extracted right + * now because the info[] array is about to become invalid. There + * is very little refcount handling here however, since we know + * that the objects that we still want to refer to now were input + * arguments to [try] and so are still on the Tcl value stack. + */ + + handlerBodyObj = info[4]; + Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0], + INT2PTR((finallyObj == NULL) ? 0 : objc - 1)); + Tcl_DecrRefCount(handlersObj); + return TclNREvalObjEx(interp, handlerBodyObj, 0, + ((Interp *) interp)->cmdFramePtr, 4*i + 5); + + handlerFailed: + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + options = During(interp, result, options, NULL); + break; + + didNotMatch: + continue; + } + + /* + * No handler matched; get rid of the list of handlers. + */ + + Tcl_DecrRefCount(handlersObj); + } + + /* + * Process the finally clause. + */ + + if (finallyObj != NULL) { + Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, + NULL); + return TclNREvalObjEx(interp, finallyObj, 0, + ((Interp *) interp)->cmdFramePtr, objc - 1); + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostHandler -- + * + * Callback to handle the outcome of the execution of a handler of a + * 'try' command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostHandler( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv; + Tcl_Obj *finallyObj; + int finally; + + objv = data[0]; + options = data[1]; + handlerKindObj = data[2]; + finally = PTR2INT(data[3]); + + cmdObj = objv[0]; + finallyObj = finally ? objv[finally] : 0; + + /* + * Check for limits/rewinding, which override normal trapping behaviour. + */ + + if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... %s\" handler line %d)", + TclGetString(cmdObj), TclGetString(handlerKindObj), + Tcl_GetErrorLine(interp))); + Tcl_DecrRefCount(options); + return TCL_ERROR; + } + + /* + * The handler result completely substitutes for the result of the body. + */ + + resultObj = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resultObj); + if (result == TCL_ERROR) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... %s\" handler line %d)", + TclGetString(cmdObj), TclGetString(handlerKindObj), + Tcl_GetErrorLine(interp))); + } else { + Tcl_DecrRefCount(options); + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + } + + /* + * Process the finally clause if it is present. + */ + + if (finallyObj != NULL) { + Interp *iPtr = (Interp *) interp; + + Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj, + NULL); + + /* The 'finally' script is always the last argument word. */ + return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr, + finally); + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TryPostFinal -- + * + * Callback to handle the outcome of the execution of the finally script + * of a 'try' command. + * + *---------------------------------------------------------------------- + */ + +static int +TryPostFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Obj *resultObj, *options, *cmdObj; + + resultObj = data[0]; + options = data[1]; + cmdObj = data[2]; + + /* + * If the result wasn't OK, we need to adjust the result options. + */ + + if (result != TCL_OK) { + Tcl_DecrRefCount(resultObj); + resultObj = NULL; + if (result == TCL_ERROR) { + options = During(interp, result, options, Tcl_ObjPrintf( + "\n (\"%s ... finally\" body line %d)", + TclGetString(cmdObj), Tcl_GetErrorLine(interp))); + } else { + Tcl_Obj *origOptions = options; + + options = Tcl_GetReturnOptions(interp, result); + Tcl_IncrRefCount(options); + Tcl_DecrRefCount(origOptions); + } + } + + /* + * Install the correct result/options into the interpreter and clean up + * any temporary storage. + */ + + result = Tcl_SetReturnOptions(interp, options); + Tcl_DecrRefCount(options); + if (resultObj != NULL) { + Tcl_SetObjResult(interp, resultObj); + Tcl_DecrRefCount(resultObj); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_WhileObjCmd -- * * This procedure is invoked to process the "while" Tcl command. See the @@ -4531,40 +5403,37 @@ Tcl_WhileObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int result, value; - Interp *iPtr = (Interp *) interp; + return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv); +} + +int +TclNRWhileObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + ForIterData *iterPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "test command"); return TCL_ERROR; } - while (1) { - result = Tcl_ExprBooleanObj(interp, objv[1], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } + /* + * We reuse [for]'s callback, passing a NULL for the 'next' script. + */ - /* 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)); - } - break; - } - } - if (result == TCL_BREAK) { - result = TCL_OK; - } - if (result == TCL_OK) { - Tcl_ResetResult(interp); - } - return result; + 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; } /* @@ -4585,32 +5454,30 @@ Tcl_WhileObjCmd( void TclListLines( - Tcl_Obj* listObj, /* Pointer to obj holding a string with list - * structure. Assumed to be valid. Assumed to - * contain n elements. - */ + 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 + Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of * derived continuation data */ { - const char* listStr = Tcl_GetString (listObj); - const char* listHead = listStr; + const char *listStr = Tcl_GetString(listObj); + const char *listHead = listStr; int i, length = strlen(listStr); const char *element = NULL, *next = NULL; - ContLineLoc* clLocPtr = TclContinuationsGet(listObj); - int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); + 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); |