summaryrefslogtreecommitdiffstats
path: root/generic/tclCmdMZ.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCmdMZ.c')
-rw-r--r--generic/tclCmdMZ.c1411
1 files changed, 1085 insertions, 326 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 0ad77aa..fc957c4 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,8 +19,50 @@
#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) */
/*
*----------------------------------------------------------------------
@@ -91,7 +133,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
@@ -105,13 +147,12 @@ 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]);
@@ -174,7 +215,7 @@ Tcl_RegexpObjCmd(
endOfForLoop:
if ((objc - i) < (2 - about)) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
+ "?-switch ...? exp string ?matchVar? ?subMatchVar ...?");
goto optionError;
}
objc -= i;
@@ -186,8 +227,8 @@ 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));
goto optionError;
}
@@ -368,11 +409,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;
}
}
@@ -392,7 +430,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;
/*
@@ -454,7 +493,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
@@ -471,7 +510,7 @@ Tcl_RegsubObjCmd(
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
- char *name;
+ const char *name;
int index;
name = TclGetString(objv[idx]);
@@ -525,7 +564,7 @@ Tcl_RegsubObjCmd(
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? exp string subSpec ?varName?");
+ "?-switch ...? exp string subSpec ?varName?");
optionError:
if (startIndex) {
Tcl_DecrRefCount(startIndex);
@@ -799,9 +838,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 {
/*
@@ -856,7 +894,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");
@@ -939,6 +977,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;
@@ -950,7 +998,7 @@ Tcl_SourceObjCmd(
fileName = objv[objc-1];
if (objc == 4) {
- static const char *options[] = {
+ static const char *const options[] = {
"-encoding", NULL
};
int index;
@@ -962,7 +1010,7 @@ Tcl_SourceObjCmd(
encodingName = TclGetString(objv[2]);
}
- return Tcl_FSEvalFileEx(interp, fileName, encodingName);
+ return TclNREvalFile(interp, fileName, encodingName);
}
/*
@@ -991,7 +1039,9 @@ Tcl_SplitObjCmd(
{
Tcl_UniChar ch;
int len;
- char *splitChars, *stringPtr, *end;
+ const char *splitChars;
+ const char *stringPtr;
+ const char *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
@@ -1036,7 +1086,8 @@ Tcl_SplitObjCmd(
* Assume Tcl_UniChar is an integral type...
*/
- hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR((int) ch),
+ &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
@@ -1044,9 +1095,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);
}
@@ -1069,7 +1120,7 @@ Tcl_SplitObjCmd(
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
- char *element, *p, *splitEnd;
+ const char *element, *p, *splitEnd;
int splitLen;
Tcl_UniChar splitChar;
@@ -1106,7 +1157,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.
@@ -1124,8 +1176,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,
@@ -1134,15 +1186,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) {
/*
@@ -1150,7 +1202,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;
}
@@ -1158,14 +1211,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
@@ -1180,18 +1233,18 @@ StringFirstCmd(
* cannot be contained in there so we can avoid searching. [Bug 2960021]
*/
- if (length1 > 0 && length1 <= length2) {
+ if (needleLen > 0 && needleLen <= haystackLen) {
register 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;
}
}
@@ -1217,7 +1270,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.
@@ -1235,8 +1289,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,
@@ -1245,15 +1299,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) {
/*
@@ -1261,7 +1315,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;
}
@@ -1269,18 +1324,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;
}
/*
@@ -1288,15 +1343,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;
}
}
@@ -1340,37 +1395,29 @@ 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 (objv[1]->typePtr == &tclByteArrayType) {
- 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)) {
+ Tcl_UniChar ch = Tcl_GetUniChar(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 = (unsigned char) ch;
- if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){
- return TCL_ERROR;
- }
- if ((index >= 0) && (index < length)) {
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
+ } else {
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));
}
@@ -1410,22 +1457,23 @@ StringIsCmd(
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 {
@@ -1539,7 +1587,6 @@ StringIsCmd(
if (stop < end) {
result = 0;
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
}
}
break;
@@ -1552,6 +1599,51 @@ 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, -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)) {
break;
@@ -1596,7 +1688,6 @@ StringIsCmd(
failat = stop - string1;
TclFreeIntRep(objPtr);
- objPtr->typePtr = NULL;
}
} else {
/*
@@ -1771,8 +1862,10 @@ StringMapCmd(
strncmp(string, "-nocase", (size_t) 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;
}
}
@@ -1809,8 +1902,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) {
@@ -1836,6 +1928,8 @@ StringMapCmd(
Tcl_SetObjResult(interp,
Tcl_NewStringObj("char map list unbalanced", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
+ "UNBALANCED", NULL);
return TCL_ERROR;
}
}
@@ -1919,12 +2013,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],
@@ -2037,8 +2129,10 @@ StringMatchCmd(
strncmp(string, "-nocase", (size_t) 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;
}
}
@@ -2072,7 +2166,6 @@ StringRangeCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const unsigned char *string;
int length, first, last;
if (objc != 4) {
@@ -2081,22 +2174,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 (objv[1]->typePtr == &tclByteArrayType) {
- 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) {
@@ -2110,17 +2192,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;
}
@@ -2189,9 +2261,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;
@@ -2212,6 +2286,7 @@ 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++) {
@@ -2489,7 +2564,7 @@ StringEqualCmd(
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
- char *string1, *string2;
+ const char *string1, *string2;
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
@@ -2510,13 +2585,16 @@ 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_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;
}
}
@@ -2537,8 +2615,8 @@ StringEqualCmd(
return TCL_OK;
}
- if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
- objv[1]->typePtr == &tclByteArrayType) {
+ 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
@@ -2636,7 +2714,7 @@ StringCmpCmd(
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
- char *string1, *string2;
+ const char *string1, *string2;
int length1, length2, i, match, length, nocase = 0, reqlength = -1;
typedef int (*strCmpFn_t)(const char *, const char *, unsigned int);
strCmpFn_t strCmpFn;
@@ -2657,13 +2735,16 @@ 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_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;
}
}
@@ -2684,8 +2765,8 @@ StringCmpCmd(
return TCL_OK;
}
- if (!nocase && objv[0]->typePtr == &tclByteArrayType &&
- objv[1]->typePtr == &tclByteArrayType) {
+ 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
@@ -2812,25 +2893,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;
}
@@ -2860,7 +2928,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?");
@@ -2944,7 +3013,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?");
@@ -3028,7 +3098,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?");
@@ -3117,8 +3188,8 @@ StringTrimCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3165,8 +3236,8 @@ StringTrimLCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3211,8 +3282,8 @@ StringTrimRCmd(
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
- string2 = " \t\n\r";
- length2 = strlen(string2);
+ string2 = DEFAULT_TRIM_SET;
+ length2 = strlen(DEFAULT_TRIM_SET);
} else {
Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?");
return TCL_ERROR;
@@ -3253,29 +3324,29 @@ 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, 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}
};
return TclMakeEnsemble(interp, "string", stringImplMap);
@@ -3300,30 +3371,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, "switch", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
@@ -3341,23 +3406,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);
}
/*
@@ -3384,9 +3465,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;
@@ -3402,7 +3492,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
};
@@ -3450,15 +3540,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
@@ -3468,8 +3559,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];
@@ -3478,8 +3572,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];
@@ -3491,17 +3588,21 @@ Tcl_SwitchObjCmd(
finishedOptions:
if (objc - i < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
- "?switches? string pattern body ... ?default body?");
+ "?-switch ...? string ?pattern body ...? ?default body?");
return TCL_ERROR;
}
if (indexVarObj != NULL && mode != OPT_REGEXP) {
- Tcl_AppendResult(interp,
- "-indexvar option requires -regexp option", 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;
}
@@ -3522,8 +3623,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;
}
@@ -3534,7 +3635,7 @@ Tcl_SwitchObjCmd(
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, savedObjv,
- "?switches? string {pattern body ... ?default body?}");
+ "?-switch ...? string {?pattern body ...? ?default body?}");
return TCL_ERROR;
}
objv = listv;
@@ -3548,7 +3649,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
@@ -3561,10 +3665,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;
}
}
@@ -3579,9 +3685,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;
}
@@ -3620,36 +3728,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;
@@ -3745,7 +3852,7 @@ Tcl_SwitchObjCmd(
*/
matchFound:
- ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
@@ -3760,7 +3867,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);
@@ -3775,7 +3882,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 {
@@ -3789,7 +3896,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;
@@ -3815,9 +3922,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.
@@ -3838,7 +3967,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;
@@ -3847,6 +3976,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
@@ -3939,6 +4131,578 @@ 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. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, dummy, objc, objv);
+}
+
+int
+TclNRTryObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
+ int i, bodyShared, haveHandlers, dummy, code;
+ static const char *const handlerNames[] = {
+ "finally", "on", "trap", NULL
+ };
+ enum Handlers {
+ TryFinally, TryOn, TryTrap
+ };
+
+ /*
+ * Parse the arguments. The handlers are passed to subsequent callbacks as
+ * a Tcl_Obj list of the 5-tuples like (type, returnCode, errorCodePrefix,
+ * bindVariables, script), and the finally script is just passed as it is.
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "body ?handler ...? ?finally script?");
+ return TCL_ERROR;
+ }
+ bodyObj = objv[1];
+ handlersObj = Tcl_NewObj();
+ bodyShared = 0;
+ haveHandlers = 0;
+ for (i=2 ; i<objc ; i++) {
+ int type;
+ Tcl_Obj *info[5];
+
+ if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type",
+ 0, &type) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ switch ((enum Handlers) type) {
+ case TryFinally: /* finally script */
+ if (i < objc-2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "finally clause must be last", -1));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+ "NONTERMINAL", NULL);
+ return TCL_ERROR;
+ } else if (i == objc-1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to finally clause: must be"
+ " \"... finally script\"", -1));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ finallyObj = objv[++i];
+ break;
+
+ case TryOn: /* on code variableList script */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to on clause: must be \"... on code"
+ " variableList script\"", -1));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ if (TclGetCompletionCodeFromObj(interp, objv[i+1],
+ &code) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+ info[2] = NULL;
+ goto commonHandler;
+
+ case TryTrap: /* trap pattern variableList script */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "wrong # args to trap clause: "
+ "must be \"... trap pattern variableList script\"",
+ -1));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+ "ARGUMENT", NULL);
+ return TCL_ERROR;
+ }
+ code = 1;
+ if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad prefix '%s': must be a list",
+ Tcl_GetString(objv[i+1])));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+ "EXNFORMAT", NULL);
+ return TCL_ERROR;
+ }
+ info[2] = objv[i+1];
+
+ commonHandler:
+ if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) {
+ Tcl_DecrRefCount(handlersObj);
+ return TCL_ERROR;
+ }
+
+ info[0] = objv[i]; /* type */
+ TclNewIntObj(info[1], code); /* returnCode */
+ if (info[2] == NULL) { /* errorCodePrefix */
+ TclNewObj(info[2]);
+ }
+ info[3] = objv[i+2]; /* bindVariables */
+ info[4] = objv[i+3]; /* script */
+
+ bodyShared = !strcmp(TclGetString(objv[i+3]), "-");
+ Tcl_ListObjAppendElement(NULL, handlersObj,
+ Tcl_NewListObj(5, info));
+ haveHandlers = 1;
+ i += 3;
+ break;
+ }
+ }
+ if (bodyShared) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "last non-finally clause must not have a body of \"-\"", -1));
+ Tcl_DecrRefCount(handlersObj);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
+ NULL);
+ return TCL_ERROR;
+ }
+ if (!haveHandlers) {
+ Tcl_DecrRefCount(handlersObj);
+ handlersObj = NULL;
+ }
+
+ /*
+ * Execute the body.
+ */
+
+ Tcl_NRAddCallback(interp, TryPostBody, handlersObj, finallyObj,
+ (ClientData)objv, INT2PTR(objc));
+ return TclNREvalObjEx(interp, bodyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, 1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * During --
+ *
+ * This helper function patches together the updates to the interpreter's
+ * return options that are needed when things fail during the processing
+ * of a handler or finally script for the [try] command.
+ *
+ * Returns:
+ * The new option dictionary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline Tcl_Obj *
+During(
+ Tcl_Interp *interp,
+ int resultCode, /* The result code from the just-evaluated
+ * script. */
+ Tcl_Obj *oldOptions, /* The old option dictionary. */
+ Tcl_Obj *errorInfo) /* An object to append to the errorinfo and
+ * release, or NULL if nothing is to be added.
+ * Designed to be used with Tcl_ObjPrintf. */
+{
+ Tcl_Obj *during, *options;
+
+ if (errorInfo != NULL) {
+ Tcl_AppendObjToErrorInfo(interp, errorInfo);
+ }
+ options = Tcl_GetReturnOptions(interp, resultCode);
+ TclNewLiteralStringObj(during, "-during");
+ Tcl_IncrRefCount(during);
+ Tcl_DictObjPut(interp, options, during, oldOptions);
+ Tcl_DecrRefCount(during);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(oldOptions);
+ return options;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostBody --
+ *
+ * Callback to handle the outcome of the execution of the body of a 'try'
+ * command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostBody(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
+ int i, dummy, code, objc;
+ int numHandlers = 0;
+
+ handlersObj = data[0];
+ finallyObj = data[1];
+ objv = data[2];
+ objc = PTR2INT(data[3]);
+
+ cmdObj = objv[0];
+
+ /*
+ * Check for limits/rewinding, which override normal trapping behaviour.
+ */
+
+ if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%s\" body line %d)", TclGetString(cmdObj),
+ Tcl_GetErrorLine(interp)));
+ if (handlersObj != NULL) {
+ Tcl_DecrRefCount(handlersObj);
+ }
+ return TCL_ERROR;
+ }
+
+ /*
+ * Basic processing of the outcome of the script, including adding of
+ * errorinfo trace.
+ */
+
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"%s\" body line %d)", TclGetString(cmdObj),
+ Tcl_GetErrorLine(interp)));
+ }
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ Tcl_ResetResult(interp);
+
+ /*
+ * Handle the results.
+ */
+
+ if (handlersObj != NULL) {
+ int found = 0;
+ Tcl_Obj **handlers, **info;
+
+ Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
+ for (i=0 ; i<numHandlers ; i++) {
+ Tcl_Obj *handlerBodyObj;
+
+ Tcl_ListObjGetElements(NULL, handlers[i], &dummy, &info);
+ if (!found) {
+ Tcl_GetIntFromObj(NULL, info[1], &code);
+ if (code != result) {
+ continue;
+ }
+
+ /*
+ * When processing an error, we must also perform list-prefix
+ * matching of the errorcode list. However, if this was an
+ * 'on' handler, the list that we are matching against will be
+ * empty.
+ */
+
+ if (code == TCL_ERROR) {
+ Tcl_Obj *errorCodeName, *errcode, **bits1, **bits2;
+ int len1, len2, j;
+
+ TclNewLiteralStringObj(errorCodeName, "-errorcode");
+ Tcl_DictObjGet(NULL, options, errorCodeName, &errcode);
+ Tcl_DecrRefCount(errorCodeName);
+ Tcl_ListObjGetElements(NULL, info[2], &len1, &bits1);
+ if (Tcl_ListObjGetElements(NULL, errcode, &len2,
+ &bits2) != TCL_OK) {
+ continue;
+ }
+ if (len2 < len1) {
+ continue;
+ }
+ for (j=0 ; j<len1 ; j++) {
+ if (strcmp(TclGetString(bits1[j]),
+ TclGetString(bits2[j])) != 0) {
+ /*
+ * Really want 'continue outerloop;', but C does
+ * not give us that.
+ */
+
+ goto didNotMatch;
+ }
+ }
+ }
+
+ found = 1;
+ }
+
+ /*
+ * Now we need to scan forward over "-" bodies. Note that we've
+ * already checked that the last body is not a "-", so this search
+ * will terminate successfully.
+ */
+
+ if (!strcmp(TclGetString(info[4]), "-")) {
+ continue;
+ }
+
+ /*
+ * Bind the variables. We already know this is a list of variable
+ * names, but it might be empty.
+ */
+
+ Tcl_ResetResult(interp);
+ result = TCL_ERROR;
+ Tcl_ListObjLength(NULL, info[3], &dummy);
+ if (dummy > 0) {
+ Tcl_Obj *varName;
+
+ Tcl_ListObjIndex(NULL, info[3], 0, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ Tcl_DecrRefCount(resultObj);
+ goto handlerFailed;
+ }
+ Tcl_DecrRefCount(resultObj);
+ if (dummy > 1) {
+ Tcl_ListObjIndex(NULL, info[3], 1, &varName);
+ if (Tcl_ObjSetVar2(interp, varName, NULL, options,
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ goto handlerFailed;
+ }
+ }
+ } else {
+ /*
+ * Dispose of the result to prevent a memleak. [Bug 2910044]
+ */
+
+ Tcl_DecrRefCount(resultObj);
+ }
+
+ /*
+ * Evaluate the handler body and process the outcome. Note that we
+ * need to keep the kind of handler for debugging purposes, and in
+ * any case anything we want from info[] must be extracted right
+ * now because the info[] array is about to become invalid. There
+ * is very little refcount handling here however, since we know
+ * that the objects that we still want to refer to now were input
+ * arguments to [try] and so are still on the Tcl value stack.
+ */
+
+ handlerBodyObj = info[4];
+ Tcl_NRAddCallback(interp, TryPostHandler, objv, options, info[0],
+ INT2PTR((finallyObj == NULL) ? 0 : objc - 1));
+ Tcl_DecrRefCount(handlersObj);
+ return TclNREvalObjEx(interp, handlerBodyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, 4*i + 5);
+
+ handlerFailed:
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ options = During(interp, result, options, NULL);
+ break;
+
+ didNotMatch:
+ continue;
+ }
+
+ /*
+ * No handler matched; get rid of the list of handlers.
+ */
+
+ Tcl_DecrRefCount(handlersObj);
+ }
+
+ /*
+ * Process the finally clause.
+ */
+
+ if (finallyObj != NULL) {
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
+ NULL);
+ return TclNREvalObjEx(interp, finallyObj, 0,
+ ((Interp *) interp)->cmdFramePtr, objc - 1);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostHandler --
+ *
+ * Callback to handle the outcome of the execution of a handler of a
+ * 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostHandler(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
+ Tcl_Obj *finallyObj;
+ int finally;
+
+ objv = data[0];
+ options = data[1];
+ handlerKindObj = data[2];
+ finally = PTR2INT(data[3]);
+
+ cmdObj = objv[0];
+ finallyObj = finally ? objv[finally] : 0;
+
+ /*
+ * Check for limits/rewinding, which override normal trapping behaviour.
+ */
+
+ if (((Interp*) interp)->execEnvPtr->rewind || Tcl_LimitExceeded(interp)) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... %s\" handler line %d)",
+ TclGetString(cmdObj), TclGetString(handlerKindObj),
+ Tcl_GetErrorLine(interp)));
+ Tcl_DecrRefCount(options);
+ return TCL_ERROR;
+ }
+
+ /*
+ * The handler result completely substitutes for the result of the body.
+ */
+
+ resultObj = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(resultObj);
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... %s\" handler line %d)",
+ TclGetString(cmdObj), TclGetString(handlerKindObj),
+ Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_DecrRefCount(options);
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ }
+
+ /*
+ * Process the finally clause if it is present.
+ */
+
+ if (finallyObj != NULL) {
+ Interp *iPtr = (Interp *) interp;
+
+ Tcl_NRAddCallback(interp, TryPostFinal, resultObj, options, cmdObj,
+ NULL);
+
+ /* The 'finally' script is always the last argument word. */
+ return TclNREvalObjEx(interp, finallyObj, 0, iPtr->cmdFramePtr,
+ finally);
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TryPostFinal --
+ *
+ * Callback to handle the outcome of the execution of the finally script
+ * of a 'try' command.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TryPostFinal(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Tcl_Obj *resultObj, *options, *cmdObj;
+
+ resultObj = data[0];
+ options = data[1];
+ cmdObj = data[2];
+
+ /*
+ * If the result wasn't OK, we need to adjust the result options.
+ */
+
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(resultObj);
+ resultObj = NULL;
+ if (result == TCL_ERROR) {
+ options = During(interp, result, options, Tcl_ObjPrintf(
+ "\n (\"%s ... finally\" body line %d)",
+ TclGetString(cmdObj), Tcl_GetErrorLine(interp)));
+ } else {
+ Tcl_Obj *origOptions = options;
+
+ options = Tcl_GetReturnOptions(interp, result);
+ Tcl_IncrRefCount(options);
+ Tcl_DecrRefCount(origOptions);
+ }
+ }
+
+ /*
+ * Install the correct result/options into the interpreter and clean up
+ * any temporary storage.
+ */
+
+ result = Tcl_SetReturnOptions(interp, options);
+ Tcl_DecrRefCount(options);
+ if (resultObj != NULL) {
+ Tcl_SetObjResult(interp, resultObj);
+ Tcl_DecrRefCount(resultObj);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_WhileObjCmd --
*
* This procedure is invoked to process the "while" Tcl command. See the
@@ -3964,40 +4728,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;
}
/*
@@ -4018,32 +4779,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);
generated by cgit v0.12 at 2024-12-05 01:43:12 (GMT)