diff options
Diffstat (limited to 'generic/tclCmdMZ.c')
| -rw-r--r-- | generic/tclCmdMZ.c | 1634 |
1 files changed, 428 insertions, 1206 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b26e298..30586b1 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-2009 Donal K. Fellows. + * 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. @@ -19,50 +19,8 @@ #include "tclInt.h" #include "tclRegexp.h" -static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, - Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); -static int SwitchPostProc(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostBody(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostFinal(ClientData data[], Tcl_Interp *interp, - int result); -static int TryPostHandler(ClientData data[], Tcl_Interp *interp, - int result); static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); - -/* - * Default set of characters to trim in [string trim] and friends. This is a - * UTF-8 literal string containing all Unicode space characters [TIP #413] - */ - -#define DEFAULT_TRIM_SET \ - "\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 +43,7 @@ int Tcl_PwdObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *retVal; @@ -125,17 +83,15 @@ int Tcl_RegexpObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, indices, match, about, all, doinline, numMatchesSaved; - int cflags, eflags, matchLength; - size_t stringLength; - ssize_t offset; + 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 @@ -149,12 +105,13 @@ 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]); @@ -194,8 +151,7 @@ Tcl_RegexpObjCmd( cflags |= TCL_REG_NLANCH; break; case REGEXP_START: { - ssize_t temp; - + int temp; if (++i >= objc) { goto endOfForLoop; } @@ -218,7 +174,7 @@ Tcl_RegexpObjCmd( endOfForLoop: if ((objc - i) < (2 - about)) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string ?matchVar? ?subMatchVar ...?"); + "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); goto optionError; } objc -= i; @@ -230,9 +186,8 @@ Tcl_RegexpObjCmd( */ if (doinline && ((objc - 2) != 0)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "regexp match variables not allowed when using -inline", - TCL_STRLEN)); + Tcl_AppendResult(interp, "regexp match variables not allowed" + " when using -inline", NULL); goto optionError; } @@ -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; } } @@ -434,8 +392,7 @@ 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; /* @@ -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; } @@ -487,19 +444,17 @@ int Tcl_RegsubObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int idx, result, cflags, all, numMatches; + int idx, result, cflags, all, wlen, wsublen, numMatches, offset; int start, end, subStart, subEnd, match; - ssize_t offset; - size_t wlen, wsublen; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; - static const char *const options[] = { + static const char *options[] = { "-all", "-nocase", "-expanded", "-line", "-linestop", "-lineanchor", "-start", "--", NULL @@ -516,7 +471,7 @@ Tcl_RegsubObjCmd( resultPtr = NULL; for (idx = 1; idx < objc; idx++) { - const char *name; + char *name; int index; name = TclGetString(objv[idx]); @@ -547,8 +502,7 @@ Tcl_RegsubObjCmd( cflags |= TCL_REG_NLANCH; break; case REGSUB_START: { - ssize_t temp; - + int temp; if (++idx >= objc) { goto endOfForLoop; } @@ -571,7 +525,7 @@ Tcl_RegsubObjCmd( endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? exp string subSpec ?varName?"); + "?switches? exp string subSpec ?varName?"); optionError: if (startIndex) { Tcl_DecrRefCount(startIndex); @@ -583,7 +537,7 @@ Tcl_RegsubObjCmd( objv += idx; if (startIndex) { - size_t stringLength = Tcl_GetCharLength(objv[1]); + int stringLength = Tcl_GetCharLength(objv[1]); TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); @@ -600,8 +554,8 @@ Tcl_RegsubObjCmd( * slightly modified version of the one pair STR_MAP code. */ - size_t slen, nocase; - int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,size_t); + int slen, nocase; + int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); Tcl_UniChar *p, wsrclc; numMatches = 0; @@ -635,7 +589,8 @@ Tcl_RegsubObjCmd( for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && - (slen==1 || (strCmpFn(wstring, wsrc, slen) == 0))) { + (slen==1 || (strCmpFn(wstring, wsrc, + (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); @@ -844,8 +799,9 @@ Tcl_RegsubObjCmd( 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 { /* @@ -897,10 +853,10 @@ int Tcl_RenameObjCmd( ClientData dummy, /* Arbitrary value passed to the command. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + 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"); @@ -933,7 +889,7 @@ int Tcl_ReturnObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int code, level; @@ -980,17 +936,7 @@ int Tcl_SourceObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t 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. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *encodingName = NULL; @@ -1004,7 +950,7 @@ TclNRSourceObjCmd( fileName = objv[objc-1]; if (objc == 4) { - static const char *const options[] = { + static const char *options[] = { "-encoding", NULL }; int index; @@ -1016,7 +962,7 @@ TclNRSourceObjCmd( encodingName = TclGetString(objv[2]); } - return TclNREvalFile(interp, fileName, encodingName); + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } /* @@ -1040,15 +986,14 @@ int Tcl_SplitObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch; int len; const char *splitChars; - const char *stringPtr; - const char *end; - size_t splitCharLen, stringLen; + char *stringPtr, *end; + int splitCharLen, stringLen; Tcl_Obj *listPtr, *objPtr; if (objc == 2) { @@ -1092,8 +1037,7 @@ Tcl_SplitObjCmd( * Assume Tcl_UniChar is an integral type... */ - hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch), - &isNew); + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); @@ -1101,9 +1045,9 @@ Tcl_SplitObjCmd( * Don't need to fiddle with refcount... */ - Tcl_SetHashValue(hPtr, objPtr); + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { - objPtr = Tcl_GetHashValue(hPtr); + objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); } Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } @@ -1126,7 +1070,8 @@ Tcl_SplitObjCmd( TclNewStringObj(objPtr, stringPtr, end - stringPtr); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } else { - const char *element, *p, *splitEnd; + char *element; + const char *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; @@ -1163,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. @@ -1179,12 +1123,11 @@ static int StringFirstCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr; - size_t needleLen, haystackLen; - ssize_t match, start; + Tcl_UniChar *ustring1, *ustring2; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1193,15 +1136,15 @@ StringFirstCmd( } /* - * We are searching haystackStr for the sequence needleStr. + * We are searching string2 for the sequence string1. */ match = -1; start = 0; - haystackLen = -1; + length2 = -1; - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); if (objc == 4) { /* @@ -1209,8 +1152,7 @@ StringFirstCmd( * point in the string before we think about a match. */ - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } @@ -1218,20 +1160,20 @@ StringFirstCmd( * Reread to prevent shimmering problems. */ - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); - if (start < 0) { + 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; - } else if (start >= haystackLen) { - goto str_first_done; - } else if (start > 0) { - haystackStr += start; - haystackLen -= start; } } @@ -1240,18 +1182,18 @@ StringFirstCmd( * cannot be contained in there so we can avoid searching. [Bug 2960021] */ - if (needleLen > 0 && needleLen <= haystackLen) { + if (length1 > 0 && length1 <= length2) { register Tcl_UniChar *p, *end; - end = haystackStr + haystackLen - needleLen + 1; - for (p = haystackStr; p < end; p++) { + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { /* * Scan forward to find the first character. */ - if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, - needleLen) == 0)) { - match = p - haystackStr; + if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; break; } } @@ -1267,7 +1209,7 @@ StringFirstCmd( } str_first_done: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } @@ -1277,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. @@ -1293,12 +1234,11 @@ static int StringLastCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr, *p; - ssize_t match, start; - size_t needleLen, haystackLen; + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start, length1, length2; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1307,15 +1247,15 @@ StringLastCmd( } /* - * We are searching haystackString for the sequence needleString. + * We are searching string2 for the sequence string1. */ match = -1; start = 0; - haystackLen = -1; + length2 = -1; - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); if (objc == 4) { /* @@ -1323,8 +1263,7 @@ StringLastCmd( * range to that char index in the string */ - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ return TCL_ERROR; } @@ -1332,18 +1271,18 @@ StringLastCmd( * Reread to prevent shimmering problems. */ - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); + ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); if (start < 0) { goto str_last_done; - } else if (start < haystackLen) { - p = haystackStr + start + 1 - needleLen; + } else if (start < length2) { + p = ustring2 + start + 1 - length1; } else { - p = haystackStr + haystackLen - needleLen; + p = ustring2 + length2 - length1; } } else { - p = haystackStr + haystackLen - needleLen; + p = ustring2 + length2 - length1; } /* @@ -1351,22 +1290,22 @@ StringLastCmd( * cannot be contained in there so we can avoid searching. [Bug 2960021] */ - if (needleLen > 0 && needleLen <= haystackLen) { - for (; p >= haystackStr; p--) { + if (length1 > 0 && length1 <= length2) { + for (; p >= ustring2; p--) { /* * Scan backwards to find the first character. */ - if ((*p == *needleStr) && !memcmp(needleStr, p, - sizeof(Tcl_UniChar) * (size_t)needleLen)) { - match = p - haystackStr; + if ((*p == *ustring1) && !memcmp(ustring1, p, + sizeof(Tcl_UniChar) * (size_t)length1)) { + match = p - ustring2; break; } } } str_last_done: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } @@ -1392,11 +1331,10 @@ static int StringIndexCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length; - ssize_t index; + int length, index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); @@ -1404,29 +1342,37 @@ StringIndexCmd( } /* - * Get the char length to calulate 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. */ - length = Tcl_GetCharLength(objv[1]); - if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { - return TCL_ERROR; - } - - if ((index >= 0) && (index < length)) { - Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index); + if (TclIsPureByteArray(objv[1])) { + const unsigned char *string = + Tcl_GetByteArrayFromObj(objv[1], &length); + 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 = (unsigned char) ch; + length = Tcl_GetCharLength(objv[1]); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); - } else { + 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; + ch = Tcl_GetUniChar(objv[1], index); length = Tcl_UniCharToUtf(ch, buf); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } @@ -1456,34 +1402,32 @@ static int StringIsCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + 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; - size_t length1, length2; + 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", "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 isClasses { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, - STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, - STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, - STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, - STR_IS_XDIGIT + 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 isOptions { @@ -1588,7 +1532,7 @@ StringIsCmd( goto str_is_done; } end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_STRLEN, + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, (const char **) &stop, 0) != TCL_OK) { result = 0; failat = 0; @@ -1597,6 +1541,7 @@ StringIsCmd( if (stop < end) { result = 0; TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } break; @@ -1609,51 +1554,6 @@ StringIsCmd( break; } goto failedIntParse; - case STR_IS_ENTIER: - if ((objPtr->typePtr == &tclIntType) || -#ifndef NO_WIDE_TYPE - (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, TCL_STRLEN, - (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)) { break; @@ -1677,7 +1577,7 @@ StringIsCmd( break; } end = string1 + length1; - if (TclParseNumber(NULL, objPtr, NULL, NULL, TCL_STRLEN, + if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { if (stop == end) { /* @@ -1698,6 +1598,7 @@ StringIsCmd( failat = stop - string1; TclFreeIntRep(objPtr); + objPtr->typePtr = NULL; } } else { /* @@ -1725,7 +1626,7 @@ StringIsCmd( */ const char *elemStart, *nextElem; - size_t lenRemain, elemSize; + int lenRemain, elemSize; register const char *p; string1 = TclGetStringFromObj(objPtr, &length1); @@ -1807,7 +1708,7 @@ StringIsCmd( str_is_done: if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(failat), + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -1851,14 +1752,14 @@ static int StringMapCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t 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"); @@ -1872,10 +1773,8 @@ StringMapCmd( strncmp(string, "-nocase", (size_t) length2) == 0) { nocase = 1; } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase", string)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string, NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } @@ -1912,7 +1811,8 @@ StringMapCmd( * adapt this code... */ - mapElemv = 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) { @@ -1937,9 +1837,7 @@ StringMapCmd( */ Tcl_SetObjResult(interp, - Tcl_NewStringObj("char map list unbalanced", TCL_STRLEN)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP", - "UNBALANCED", NULL); + Tcl_NewStringObj("char map list unbalanced", -1)); return TCL_ERROR; } } @@ -1981,7 +1879,7 @@ StringMapCmd( * larger strings. */ - size_t mapLen; + int mapLen; Tcl_UniChar *mapString, u2lc; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); @@ -1999,7 +1897,7 @@ StringMapCmd( if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, - length2) == 0)) { + (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; @@ -2014,7 +1912,7 @@ StringMapCmd( } } else { Tcl_UniChar **mapStrings, *u2lc = NULL; - size_t *mapLens; + int *mapLens; /* * Precompute pointers to the unicode string and length. This saves us @@ -2023,10 +1921,12 @@ StringMapCmd( * case. */ - mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); - mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(size_t)); + mapStrings = (Tcl_UniChar **) TclStackAlloc(interp, + mapElemc * 2 * sizeof(Tcl_UniChar *)); + mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); + u2lc = (Tcl_UniChar *) TclStackAlloc(interp, + mapElemc * sizeof(Tcl_UniChar)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -2047,7 +1947,7 @@ 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. @@ -2121,7 +2021,7 @@ static int StringMatchCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int nocase = 0; @@ -2132,17 +2032,15 @@ StringMatchCmd( } if (objc == 4) { - size_t length; + int length; const char *string = TclGetStringFromObj(objv[1], &length); if ((length > 1) && 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, NULL); + Tcl_AppendResult(interp, "bad option \"", string, + "\": must be -nocase", NULL); return TCL_ERROR; } } @@ -2173,11 +2071,11 @@ static int StringRangeCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length; - ssize_t first, last; + const unsigned char *string; + int length, first, last; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "string first last"); @@ -2185,11 +2083,22 @@ 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. */ - length = Tcl_GetCharLength(objv[1]) - 1; + 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; + } if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { @@ -2199,11 +2108,21 @@ StringRangeCmd( if (first < 0) { first = 0; } - if (last >= length && last > 0) { + if (last >= length) { last = length; } if (last >= first) { - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + 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; } @@ -2230,13 +2149,12 @@ static int StringReptCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1; char *string2; - int count; - size_t index, length1, length2; + int count, index, length1, length2; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2273,11 +2191,9 @@ 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)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + "result exceeds max size for a Tcl value (%d bytes)", INT_MAX)); return TCL_ERROR; } length2 = length1 * count; @@ -2286,7 +2202,7 @@ StringReptCmd( * Include space for the NUL. */ - string2 = attemptckalloc(length2 + 1); + string2 = attemptckalloc((unsigned) length2 + 1); if (string2 == NULL) { /* * Alloc failed. Note that in this case we try to do an error message @@ -2296,9 +2212,8 @@ StringReptCmd( */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow, out of memory allocating %lu bytes", + "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++) { @@ -2343,12 +2258,11 @@ static int StringRplcCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar *ustring; - ssize_t first, last; - size_t length; + int first, last, length; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); @@ -2363,10 +2277,6 @@ StringRplcCmd( return TCL_ERROR; } - if (first < 0) { - first = 0; - } - if ((last < first) || (last < 0) || (first > length)) { Tcl_SetObjResult(interp, objv[1]); } else { @@ -2375,6 +2285,10 @@ StringRplcCmd( ustring = Tcl_GetUnicodeFromObj(objv[1], &length); length--; + if (first < 0) { + first = 0; + } + resultPtr = Tcl_NewUnicodeObj(ustring, first); if (objc == 5) { Tcl_AppendObjToObj(resultPtr, objv[4]); @@ -2410,7 +2324,7 @@ static int StringRevCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { @@ -2445,13 +2359,12 @@ static int StringStartCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch; const char *p, *string; - size_t cur, length, numChars; - ssize_t index; + int cur, index, length, numChars; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); @@ -2464,13 +2377,13 @@ StringStartCmd( return TCL_ERROR; } string = TclGetStringFromObj(objv[1], &length); - if (index >= numChars && index >= 0) { + if (index >= numChars) { index = numChars - 1; } cur = 0; if (index > 0) { p = Tcl_UtfAtIndex(string, index); - for (cur = index+1; cur --> 0 ;) { + for (cur = index; cur >= 0; cur--) { TclUtfToUniChar(p, &ch); if (!Tcl_UniCharIsWordChar(ch)) { break; @@ -2481,7 +2394,7 @@ StringStartCmd( cur += 1; } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } @@ -2507,13 +2420,12 @@ static int StringEndCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_UniChar ch; const char *p, *end, *string; - size_t cur, length, numChars; - ssize_t index; + int cur, index, length, numChars; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "string index"); @@ -2570,7 +2482,7 @@ static int StringEqualCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* @@ -2579,10 +2491,9 @@ StringEqualCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - size_t length1, length2, i, match, length; - int nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t)(const char *, const char *, size_t); + 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) { @@ -2601,16 +2512,13 @@ StringEqualCmd( if (i+1 >= objc-2) { goto str_cmp_args; } - i++; + ++i; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string2)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); return TCL_ERROR; } } @@ -2689,7 +2597,7 @@ StringEqualCmd( reqlength = length + 1; } - match = strCmpFn(string1, string2, length); + match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } @@ -2721,7 +2629,7 @@ static int StringCmpCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { /* @@ -2730,10 +2638,9 @@ StringCmpCmd( * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ - const char *string1, *string2; - size_t length1, length2, i, length; - int nocase = 0, reqlength = -1, match; - typedef int (*strCmpFn_t)(const char *, const char *, size_t); + 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) { @@ -2752,16 +2659,13 @@ StringCmpCmd( if (i+1 >= objc-2) { goto str_cmp_args; } - i++; + ++i; if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad option \"%s\": must be -nocase or -length", - string2)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", - string2, NULL); + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", NULL); return TCL_ERROR; } } @@ -2837,7 +2741,7 @@ StringCmpCmd( reqlength = length + 1; } - match = strCmpFn(string1, string2, length); + match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } @@ -2870,10 +2774,10 @@ static int StringBytesCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t length; + int length; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); @@ -2881,7 +2785,7 @@ StringBytesCmd( } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } @@ -2907,15 +2811,28 @@ static int StringLenCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + 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(Tcl_GetCharLength(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; } @@ -2941,12 +2858,11 @@ static int StringLowerCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t 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?"); @@ -2962,7 +2878,7 @@ StringLowerCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - ssize_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; @@ -2997,7 +2913,7 @@ StringLowerCmd( length2 = Tcl_UtfToLower(string2); Tcl_SetObjLength(resultPtr, length2 + (start - string1)); - Tcl_AppendToObj(resultPtr, end, TCL_STRLEN); + Tcl_AppendToObj(resultPtr, end, -1); Tcl_SetObjResult(interp, resultPtr); } @@ -3026,12 +2942,11 @@ static int StringUpperCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t 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?"); @@ -3047,7 +2962,7 @@ StringUpperCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - ssize_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; @@ -3082,7 +2997,7 @@ StringUpperCmd( length2 = Tcl_UtfToUpper(string2); Tcl_SetObjLength(resultPtr, length2 + (start - string1)); - Tcl_AppendToObj(resultPtr, end, TCL_STRLEN); + Tcl_AppendToObj(resultPtr, end, -1); Tcl_SetObjResult(interp, resultPtr); } @@ -3111,12 +3026,11 @@ static int StringTitleCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - size_t 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?"); @@ -3132,7 +3046,7 @@ StringTitleCmd( Tcl_SetObjLength(resultPtr, length1); Tcl_SetObjResult(interp, resultPtr); } else { - ssize_t first, last; + int first, last; const char *start, *end; Tcl_Obj *resultPtr; @@ -3167,7 +3081,7 @@ StringTitleCmd( length2 = Tcl_UtfToTitle(string2); Tcl_SetObjLength(resultPtr, length2 + (start - string1)); - Tcl_AppendToObj(resultPtr, end, TCL_STRLEN); + Tcl_AppendToObj(resultPtr, end, -1); Tcl_SetObjResult(interp, resultPtr); } @@ -3196,17 +3110,17 @@ static int StringTrimCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - size_t triml, trimr, length1, length2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3244,17 +3158,17 @@ static int StringTrimLCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - size_t trim, length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3290,17 +3204,17 @@ static int StringTrimRCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - size_t trim, length1, length2; + int trim, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); } else if (objc == 2) { - string2 = DEFAULT_TRIM_SET; - length2 = strlen(DEFAULT_TRIM_SET); + string2 = " \t\n\r"; + length2 = strlen(string2); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; @@ -3341,29 +3255,29 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { - {"bytelength", StringBytesCmd, NULL, 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, NULL, 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, NULL, NULL, NULL, 0}, - {"replace", StringRplcCmd, NULL, NULL, NULL, 0}, - {"reverse", StringRevCmd, NULL, NULL, NULL, 0}, - {"tolower", StringLowerCmd, NULL, NULL, NULL, 0}, - {"toupper", StringUpperCmd, NULL, NULL, NULL, 0}, - {"totitle", StringTitleCmd, NULL, NULL, NULL, 0}, - {"trim", StringTrimCmd, NULL, NULL, NULL, 0}, - {"trimleft", StringTrimLCmd, NULL, NULL, NULL, 0}, - {"trimright", StringTrimRCmd, NULL, NULL, NULL, 0}, - {"wordend", StringEndCmd, NULL, NULL, NULL, 0}, - {"wordstart", StringStartCmd, NULL, 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); @@ -3388,24 +3302,30 @@ TclInitStringCmd( */ int -TclSubstOptions( - Tcl_Interp *interp, - size_t 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, "switch", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } @@ -3423,39 +3343,23 @@ TclSubstOptions( Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } - *flagPtr = flags; - return TCL_OK; -} - -int -Tcl_SubstObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - size_t 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. */ - size_t 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; } /* @@ -3479,22 +3383,12 @@ int Tcl_SwitchObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, dummy, objc, objv); -} - -int -TclNRSwitchObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int i,j, index, mode, foundmode, splitObjs, numMatchesSaved, noCase; - size_t patternLength; - 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; @@ -3510,7 +3404,7 @@ 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 }; @@ -3527,7 +3421,7 @@ TclNRSwitchObjCmd( matchVarObj = NULL; numMatchesSaved = 0; noCase = 0; - for (i = 1; i+2 < objc; i++) { + for (i = 1; i < objc-2; i++) { if (TclGetString(objv[i])[0] != '-') { break; } @@ -3544,7 +3438,7 @@ TclNRSwitchObjCmd( i++; goto finishedOptions; case OPT_NOCASE: - strCmpFn = strcasecmp; + strCmpFn = TclUtfCasecmp; noCase = 1; break; @@ -3558,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", 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 @@ -3577,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", NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-indexvar", " option", NULL); return TCL_ERROR; } indexVarObj = objv[i]; @@ -3590,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", NULL); + Tcl_AppendResult(interp, "missing variable name argument to ", + "-matchvar", " option", NULL); return TCL_ERROR; } matchVarObj = objv[i]; @@ -3606,21 +3493,17 @@ TclNRSwitchObjCmd( finishedOptions: if (objc - i < 2) { Tcl_WrongNumArgs(interp, 1, objv, - "?-switch ...? 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", 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", NULL); + Tcl_AppendResult(interp, + "-matchvar option requires -regexp option", NULL); return TCL_ERROR; } @@ -3641,8 +3524,8 @@ TclNRSwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - blist = objv[0]; + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ return TCL_ERROR; } @@ -3653,7 +3536,7 @@ TclNRSwitchObjCmd( if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, - "?-switch ...? string {?pattern body ...? ?default body?}"); + "?switches? string {pattern body ... ?default body?}"); return TCL_ERROR; } objv = listv; @@ -3667,10 +3550,7 @@ TclNRSwitchObjCmd( if (objc % 2) { Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra switch pattern with no body", TCL_STRLEN)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM", - 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 @@ -3683,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", TCL_STRLEN); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", - "BADARM", "COMMENT?", NULL); + Tcl_AppendResult(interp, ", this may be due to a " + "comment incorrectly placed outside of a " + "switch body - see the \"switch\" " + "documentation", NULL); break; } } @@ -3703,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", NULL); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "no body specified for pattern \"", + TclGetString(objv[objc-2]), "\"", NULL); return TCL_ERROR; } @@ -3746,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; @@ -3870,7 +3747,7 @@ TclNRSwitchObjCmd( */ matchFound: - ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); *ctxPtr = *iPtr->cmdFramePtr; if (splitObjs) { @@ -3885,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); @@ -3900,7 +3777,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = ckalloc(objc * sizeof(int)); + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3914,7 +3791,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = ckalloc(objc * sizeof(int)); + ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3940,31 +3817,9 @@ TclNRSwitchObjCmd( * TIP #280: Make invoking context available to switch branch. */ - Tcl_NRAddCallback(interp, SwitchPostProc, INT2PTR(splitObjs), ctxPtr, - INT2PTR(pc), (ClientData) pattern); - return TclNREvalObjEx(interp, objv[j], 0, ctxPtr, splitObjs ? j : bidx+j); -} - -static int -SwitchPostProc( - ClientData data[], /* Data passed from Tcl_NRAddCallback above */ - Tcl_Interp *interp, /* Tcl interpreter */ - int result) /* Result to return*/ -{ - /* Unpack the preserved data */ - - int splitObjs = PTR2INT(data[0]); - CmdFrame *ctxPtr = data[1]; - int pc = PTR2INT(data[2]); - const char *pattern = data[3]; - int patternLength = strlen(pattern); - - /* - * Clean up TIP 280 context information - */ - + 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. @@ -3985,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; @@ -3994,69 +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. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -int -Tcl_ThrowObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *options; - size_t 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", TCL_STRLEN)); - 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 @@ -4075,7 +3867,7 @@ int Tcl_TimeObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Tcl_Obj *objPtr; @@ -4149,580 +3941,6 @@ Tcl_TimeObjCmd( /* *---------------------------------------------------------------------- * - * 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. */ - size_t 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. */ - size_t objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL; - int i, bodyShared, haveHandlers, code; - size_t 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]; - handlersObj = Tcl_NewObj(); - bodyShared = 0; - haveHandlers = 0; - for (i=2 ; i<objc ; i++) { - int type; - Tcl_Obj *info[5]; - - if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", - 0, &type) != TCL_OK) { - Tcl_DecrRefCount(handlersObj); - return TCL_ERROR; - } - switch ((enum Handlers) type) { - case TryFinally: /* finally script */ - if (i+2 < objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "finally clause must be last", TCL_STRLEN)); - Tcl_DecrRefCount(handlersObj); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY", - "NONTERMINAL", NULL); - return TCL_ERROR; - } else if (i+1 == objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args to finally clause: must be" - " \"... finally script\"", TCL_STRLEN)); - 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+4 > objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args to on clause: must be \"... on code" - " variableList script\"", TCL_STRLEN)); - 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+4 > objc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "wrong # args to trap clause: " - "must be \"... trap pattern variableList script\"", - TCL_STRLEN)); - 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 \"-\"", - TCL_STRLEN)); - 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, code, objc; - size_t dummy, 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; - size_t 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 @@ -4745,40 +3963,43 @@ int Tcl_WhileObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, dummy, objc, objv); -} - -int -TclNRWhileObjCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - ForIterData *iterPtr; + int result, value; + Interp *iPtr = (Interp *) interp; 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; + while (1) { + result = Tcl_ExprBooleanObj(interp, objv[1], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } - TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, - NULL, NULL); - return TCL_OK; + /* 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; } /* @@ -4786,8 +4007,7 @@ TclNRWhileObjCmd( * * TclListLines -- * - * Compute line information for sub-subelements. Used in some types of - * [switch]es and in the processing of lambdas by [apply]. + * ??? * * Results: * Filled in array of line numbers? @@ -4800,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_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. */ - size_t numLines, /* #elements in lines */ + 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; - size_t 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); - ssize_t *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); + ContLineLoc* clLocPtr = TclContinuationsGet(listObj); + int* clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL); - for (i = 0; i < numLines; i++) { + 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); |