summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls10
-rw-r--r--generic/tcl.h6
-rw-r--r--generic/tclCmdMZ.c16
-rw-r--r--generic/tclCompCmds.c18
-rw-r--r--generic/tclDecls.h20
-rw-r--r--generic/tclEncoding.c25
-rw-r--r--generic/tclExecute.c26
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclStringObj.c70
-rw-r--r--generic/tclTrace.c53
-rw-r--r--generic/tclUtf.c236
-rw-r--r--generic/tclVar.c961
12 files changed, 869 insertions, 576 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 3e1825c..0200257 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -1145,16 +1145,16 @@ declare 319 {
Tcl_QueuePosition position)
}
declare 320 {
- Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index)
+ int Tcl_UniCharAtIndex(const char *src, int index)
}
declare 321 {
- Tcl_UniChar Tcl_UniCharToLower(int ch)
+ int Tcl_UniCharToLower(int ch)
}
declare 322 {
- Tcl_UniChar Tcl_UniCharToTitle(int ch)
+ int Tcl_UniCharToTitle(int ch)
}
declare 323 {
- Tcl_UniChar Tcl_UniCharToUpper(int ch)
+ int Tcl_UniCharToUpper(int ch)
}
declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
@@ -1348,7 +1348,7 @@ declare 380 {
int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
- Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
+ int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
declare 382 {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
diff --git a/generic/tcl.h b/generic/tcl.h
index ffead99..61de945 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2158,7 +2158,7 @@ typedef struct Tcl_EncodingType {
*/
#ifndef TCL_UTF_MAX
-#define TCL_UTF_MAX 3
+#define TCL_UTF_MAX 4
#endif
/*
@@ -2348,10 +2348,10 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
/*
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
- * stubs tables.
+ * stubs tables. If TCL_UTF_MAX>4 use a different value.
*/
-#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
+#define TCL_STUB_MAGIC ((int) 0xFCA3BACF + (TCL_UTF_MAX>4))
/*
* The following function is required to be defined in all stubs aware
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 441a9a6..4fcc93d 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -491,7 +491,7 @@ Tcl_RegsubObjCmd(
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
- Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend;
+ Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
"-all", "-command", "-expanded", "-line",
@@ -1220,7 +1220,7 @@ Tcl_SplitObjCmd(
len = TclUtfToUniChar(stringPtr, &ch);
fullchar = ch;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (!len) {
len += TclUtfToUniChar(stringPtr, &ch);
fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
@@ -1419,7 +1419,7 @@ StringIndexCmd(
}
/*
- * Get the char length to calulate what 'end' means.
+ * Get the char length to calculate what 'end' means.
*/
length = Tcl_GetCharLength(objv[1]);
@@ -1428,7 +1428,11 @@ StringIndexCmd(
}
if ((index >= 0) && (index < length)) {
- Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index);
+ int ch = Tcl_GetUniChar(objv[1], index);
+
+ if (ch == -1) {
+ return TCL_OK;
+ }
/*
* If we have a ByteArray object, we're careful to generate a new
@@ -1440,7 +1444,7 @@ StringIndexCmd(
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
- char buf[TCL_UTF_MAX];
+ char buf[4];
length = Tcl_UniCharToUtf(ch, buf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
@@ -1803,7 +1807,7 @@ StringIsCmd(
int fullchar;
length2 = TclUtfToUniChar(string1, &ch);
fullchar = ch;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (!length2) {
length2 = TclUtfToUniChar(string1, &ch);
fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index b9bc228..3a162cc 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -322,11 +322,22 @@ TclCompileArraySetCmd(
*/
if (isDataValid && !isDataEven) {
+ /* Abandon custom compile and let invocation raise the error */
+ code = TclCompileBasic2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
+ goto done;
+
+ /*
+ * We used to compile to the bytecode that would throw the error,
+ * but that was wrong because it would not invoke the array trace
+ * on the variable.
+ *
PushStringLiteral(envPtr, "list must have an even number of elements");
PushStringLiteral(envPtr, "-errorcode {TCL ARGUMENT FORMAT}");
TclEmitInstInt4(INST_RETURN_IMM, TCL_ERROR, envPtr);
TclEmitInt4( 0, envPtr);
goto done;
+ *
+ */
}
/*
@@ -404,6 +415,10 @@ TclCompileArraySetCmd(
* Start issuing instructions to write to the array.
*/
+ TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
+ TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
+ TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
+
CompileWord(envPtr, dataTokenPtr, interp, 2);
if (!isDataLiteral || !isDataValid) {
/*
@@ -428,9 +443,6 @@ TclCompileArraySetCmd(
TclStoreInt1AtPtr(fwd, envPtr->codeStart+offsetFwd+1);
}
- TclEmitInstInt4(INST_ARRAY_EXISTS_IMM, localIndex, envPtr);
- TclEmitInstInt1(INST_JUMP_TRUE1, 7, envPtr);
- TclEmitInstInt4(INST_ARRAY_MAKE_IMM, localIndex, envPtr);
TclEmitInstInt4(INST_FOREACH_START, infoIndex, envPtr);
offsetBack = CurrentOffset(envPtr);
Emit14Inst( INST_LOAD_SCALAR, keyVar, envPtr);
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 5a03288..252b46e 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -962,13 +962,13 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
Tcl_Event *evPtr, Tcl_QueuePosition position);
/* 320 */
-EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index);
+EXTERN int Tcl_UniCharAtIndex(const char *src, int index);
/* 321 */
-EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch);
+EXTERN int Tcl_UniCharToLower(int ch);
/* 322 */
-EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch);
+EXTERN int Tcl_UniCharToTitle(int ch);
/* 323 */
-EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
+EXTERN int Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
@@ -1123,7 +1123,7 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
/* 380 */
EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
-EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
+EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
/* 382 */
EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
@@ -2207,10 +2207,10 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
- Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
- Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */
- Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
- Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
+ int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
+ int (*tcl_UniCharToLower) (int ch); /* 321 */
+ int (*tcl_UniCharToTitle) (int ch); /* 322 */
+ int (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
@@ -2268,7 +2268,7 @@ typedef struct TclStubs {
Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
- Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
+ int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 7c07f27..e233e57 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -2375,8 +2375,15 @@ UtfToUtfProc(
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
- src += TclUtfToUniChar(src, chPtr);
+ int len = TclUtfToUniChar(src, chPtr);
+ src += len;
dst += Tcl_UniCharToUtf(*chPtr, dst);
+#if TCL_UTF_MAX <= 4
+ if (!len) {
+ src += TclUtfToUniChar(src, chPtr);
+ dst += Tcl_UniCharToUtf(*chPtr, dst);
+ }
+#endif
}
}
@@ -2782,7 +2789,7 @@ TableFromUtfProc(
}
len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 4
/*
* This prevents a crash condition. More evaluation is required for
* full support of int Tcl_UniChar. [Bug 1004065]
@@ -2791,6 +2798,10 @@ TableFromUtfProc(
if (ch & 0xffff0000) {
word = 0;
} else
+#else
+ if (!len) {
+ word = 0;
+ } else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xff];
@@ -2988,12 +2999,18 @@ Iso88591FromUtfProc(
* Check for illegal characters.
*/
- if (ch > 0xff) {
+ if (ch > 0xff
+#if TCL_UTF_MAX <= 4
+ || !len
+#endif
+ ) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
-
+#if TCL_UTF_MAX <= 4
+ if (!len) len = 4;
+#endif
/*
* Plunge on, using '?' as a fallback character.
*/
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 6c52fdb..0200dc9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3898,7 +3898,8 @@ TEBCresume(
}
TRACE(("%s %u \"%.30s\" => ",
(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
- if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
+ if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)
+ && !(arrayPtr->flags & VAR_SEARCH_ACTIVE)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
if (varPtr && TclIsVarDirectUnsettable(varPtr)) {
/*
@@ -4023,17 +4024,12 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL,
/*createPart1*/0, /*createPart2*/0, &arrayPtr);
doArrayExists:
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- DECACHE_STACK_INFO();
- result = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,
- NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|
- TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
- CACHE_STACK_INFO();
- if (result == TCL_ERROR) {
- TRACE_ERROR(interp);
- goto gotError;
- }
+ DECACHE_STACK_INFO();
+ result = TclCheckArrayTraces(interp, varPtr, arrayPtr, part1Ptr, opnd);
+ CACHE_STACK_INFO();
+ if (result == TCL_ERROR) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
objResultPtr = TCONST(1);
@@ -5305,8 +5301,8 @@ TEBCresume(
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
- char buf[TCL_UTF_MAX];
- Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index);
+ char buf[4];
+ int ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1)
@@ -5314,7 +5310,7 @@ TEBCresume(
* practical use.
*/
- length = Tcl_UniCharToUtf(ch, buf);
+ length = (ch != -1) ? Tcl_UniCharToUtf(ch, buf) : 0;
objResultPtr = Tcl_NewStringObj(buf, length);
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5e6a5fe..2aa36e5 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2889,8 +2889,6 @@ MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
CmdFrame **cfPtrPtr, int *wordPtr);
-MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
- Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum);
MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
int strLen, const unsigned char *pattern,
@@ -2898,6 +2896,8 @@ MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
MODULE_SCOPE double TclCeil(const mp_int *a);
MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
+MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
+ Var *arrayPtr, Tcl_Obj *name, int index);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
const char *value);
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 93691a3..2e44e0e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -460,8 +460,9 @@ Tcl_GetCharLength(
*
* Tcl_GetUniChar --
*
- * Get the index'th Unicode character from the String object. The index
- * is assumed to be in the appropriate range.
+ * Get the index'th Unicode character from the String object. If index
+ * is out of range or it references a low surrogate preceded by a high
+ * surrogate, the result = -1;
*
* Results:
* Returns the index'th Unicode character in the Object.
@@ -472,13 +473,18 @@ Tcl_GetCharLength(
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
int index) /* Get the index'th Unicode character. */
{
String *stringPtr;
+ int ch, length;
+
+ if (index < 0) {
+ return -1;
+ }
/*
* Optimize the case where we're really dealing with a bytearray object
@@ -486,9 +492,12 @@ Tcl_GetUniChar(
*/
if (TclIsPureByteArray(objPtr)) {
- unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+ if (index >= length) {
+ return -1;
+ }
- return (Tcl_UniChar) bytes[index];
+ return (int) bytes[index];
}
/*
@@ -512,7 +521,26 @@ Tcl_GetUniChar(
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
- return stringPtr->unicode[index];
+
+ if (index >= stringPtr->numChars) {
+ return -1;
+ }
+ ch = stringPtr->unicode[index];
+#if TCL_UTF_MAX <= 4
+ /* See: bug [11ae2be95dac9417] */
+ if ((ch&0xF800) == 0xD800) {
+ if (ch&0x400) {
+ if ((index > 0) && ((stringPtr->unicode[index-1]&0xFC00) == 0xD800)) {
+ ch = -1; /* low surrogate preceded by high surrogate */
+ }
+ } else if ((++index < stringPtr->numChars)
+ && ((stringPtr->unicode[index]&0xFC00) == 0xDC00)) {
+ /* high surrogate followed by low surrogate */
+ ch = (((ch & 0x3FF) << 10) | (stringPtr->unicode[index] & 0x3FF)) + 0x10000;
+ }
+ }
+#endif
+ return ch;
}
/*
@@ -612,15 +640,24 @@ Tcl_GetRange(
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
+ int length;
+ if (first < 0) {
+ first = 0;
+ }
/*
* Optimize the case where we're really dealing with a bytearray object
* we don't need to convert to a string to perform the substring operation.
*/
if (TclIsPureByteArray(objPtr)) {
- unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL);
-
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
+ if (last >= length) {
+ last = length - 1;
+ }
+ if (last < first) {
+ return Tcl_NewObj();
+ }
return Tcl_NewByteArrayObj(bytes+first, last-first+1);
}
@@ -640,6 +677,12 @@ Tcl_GetRange(
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
+ if (last >= stringPtr->numChars) {
+ last = stringPtr->numChars - 1;
+ }
+ if (last < first) {
+ return Tcl_NewObj();
+ }
newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1);
/*
@@ -654,8 +697,13 @@ Tcl_GetRange(
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
-
-#if TCL_UTF_MAX == 4
+ if (last > stringPtr->numChars) {
+ last = stringPtr->numChars;
+ }
+ if (last < first) {
+ return Tcl_NewObj();
+ }
+#if TCL_UTF_MAX <= 4
/* See: bug [11ae2be95dac9417] */
if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
@@ -1930,7 +1978,7 @@ Tcl_AppendFormatToObj(
}
break;
case 'c': {
- char buf[TCL_UTF_MAX];
+ char buf[4];
int code, length;
if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) {
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index f86f472..8663eae 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -191,8 +191,10 @@ Tcl_TraceObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
int optionIndex;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
const char *name;
const char *flagOps, *p;
+#endif
/* Main sub commands to 'trace' */
static const char *const traceOptions[] = {
"add", "info", "remove",
@@ -365,12 +367,14 @@ Tcl_TraceObjCmd(
}
return TCL_OK;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
badVarOps:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad operations \"%s\": should be one or more of rwua",
flagOps));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
return TCL_ERROR;
+#endif
}
/*
@@ -912,9 +916,11 @@ TraceVariableObjCmd(
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
}
+#endif
ctvarPtr->traceCmdInfo.length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
@@ -939,7 +945,11 @@ TraceVariableObjCmd(
TraceVarInfo *tvarPtr = clientData;
if ((tvarPtr->length == length)
- && ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
+ && ((tvarPtr->flags
+#ifndef TCL_REMOVE_OBSOLETE_TRACES
+& ~TCL_TRACE_OLD_STYLE
+#endif
+ )==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
@@ -2468,6 +2478,47 @@ TclVarTraceExists(
/*
*----------------------------------------------------------------------
*
+ * TclCheckArrayTraces --
+ *
+ * This function is invoked to when we operate on an array variable,
+ * to allow any array traces to fire.
+ *
+ * Results:
+ * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR if
+ * invocation of a trace function indicated an error. When TCL_ERROR is
+ * returned, then error information is left in interp.
+ *
+ * Side effects:
+ * Almost anything can happen, depending on trace; this function itself
+ * doesn't have any side effects.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCheckArrayTraces(
+ Tcl_Interp *interp,
+ Var *varPtr,
+ Var *arrayPtr,
+ Tcl_Obj *name,
+ int index)
+{
+ int code = TCL_OK;
+
+ if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
+ && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
+ Interp *iPtr = (Interp *)interp;
+
+ code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL,
+ (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY),
+ /* leaveErrMsg */ 1, index);
+ }
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCallVarTraces --
*
* This function is invoked to find and invoke relevant trace functions
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 2d8750d..319bfa0 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -98,11 +98,9 @@ TclUtfCount(
if (ch <= 0x7FF) {
return 2;
}
-#if TCL_UTF_MAX > 3
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
-#endif
return 3;
}
@@ -131,7 +129,7 @@ Tcl_UniCharToUtf(
char *buf) /* Buffer in which the UTF-8 representation of
* the Tcl_UniChar is stored. Buffer must be
* large enough to hold the UTF-8 character
- * (at most TCL_UTF_MAX bytes). */
+ * (at most 4 bytes). */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
buf[0] = (char) ch;
@@ -144,27 +142,30 @@ Tcl_UniCharToUtf(
return 2;
}
if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX == 4
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x0400) {
/* Low surrogate */
- buf[3] = (char) ((ch | 0x80) & 0xBF);
- buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F);
- return 4;
+ if (((buf[0] & 0xF8) == 0xF0) && ((buf[1] & 0xC0) == 0x80)
+ && ((buf[2] & 0xCF) == 0)) {
+ /* Previous Tcl_UniChar was a High surrogate, so combine */
+ buf[3] = (char) ((ch & 0x3F) | 0x80);
+ buf[2] |= (char) (((ch >> 6) & 0x0F) | 0x80);
+ return 4;
+ }
+ /* Previous Tcl_UniChar was not a High surrogate, so just output */
} else {
/* High surrogate */
ch += 0x40;
- buf[2] = (char) (((ch << 4) | 0x80) & 0xB0);
- buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF);
- buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7);
+ /* Fill buffer with specific 3-byte (invalid) byte combination,
+ so following Low surrogate can recognize it and combine */
+ buf[2] = (char) ((ch << 4) & 0x30);
+ buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80);
+ buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0);
return 0;
}
}
-#endif
goto three;
}
-
-#if TCL_UTF_MAX > 3
if (ch <= 0x10FFFF) {
buf[3] = (char) ((ch | 0x80) & 0xBF);
buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
@@ -172,7 +173,6 @@ Tcl_UniCharToUtf(
buf[0] = (char) ((ch >> 18) | 0xF0);
return 4;
}
-#endif
}
ch = 0xFFFD;
@@ -214,12 +214,11 @@ Tcl_UniCharToUtfDString(
int oldLength;
/*
- * UTF-8 string length in bytes will be <= Unicode string length *
- * TCL_UTF_MAX.
+ * UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
oldLength = Tcl_DStringLength(dsPtr);
- Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * TCL_UTF_MAX);
+ Tcl_DStringSetLength(dsPtr, (oldLength + uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
@@ -268,6 +267,13 @@ Tcl_UniCharToUtfDString(
*---------------------------------------------------------------------------
*/
+static const unsigned short cp1252[32] = {
+ 0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
+ 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
+ 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
+ 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
+};
+
int
Tcl_UtfToUniChar(
register const char *src, /* The UTF-8 string. */
@@ -284,11 +290,17 @@ Tcl_UtfToUniChar(
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
- * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid
+ * Treats naked trail bytes 0x80 to 0x9F as valid characters from
+ * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
+ * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
- *chPtr = (Tcl_UniChar) byte;
+ if ((unsigned)(byte-0x80) < (unsigned) 0x20) {
+ *chPtr = (Tcl_UniChar) cp1252[byte-0x80];
+ } else {
+ *chPtr = (Tcl_UniChar) byte;
+ }
return 1;
} else if (byte < 0xE0) {
if ((src[1] & 0xC0) == 0x80) {
@@ -329,17 +341,7 @@ Tcl_UtfToUniChar(
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
-#if TCL_UTF_MAX == 3
- byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
- | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000;
- if (byte & 0x100000) {
- /* out of range, < 0x10000 or > 0x10ffff */
- } else {
- /* produce replacement character, and advance source pointer */
- *chPtr = (Tcl_UniChar) 0xFFFD;
- return 4;
- }
-#elif TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
Tcl_UniChar surrogate;
byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
@@ -551,7 +553,7 @@ Tcl_UtfFindFirst(
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (!len) {
len += TclUtfToUniChar(src, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
@@ -599,7 +601,7 @@ Tcl_UtfFindLast(
while (1) {
len = TclUtfToUniChar(src, &find);
fullchar = find;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (!len) {
len += TclUtfToUniChar(src, &find);
fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000;
@@ -642,7 +644,7 @@ Tcl_UtfNext(
Tcl_UniChar ch = 0;
int len = TclUtfToUniChar(src, &ch);
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (len == 0) {
len = TclUtfToUniChar(src, &ch);
}
@@ -717,17 +719,33 @@ Tcl_UtfPrev(
*---------------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharAtIndex(
register const char *src, /* The UTF-8 string to dereference. */
register int index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
+ int fullchar = 0;
+#if TCL_UTF_MAX <= 4
+ int len = 1;
+#endif
while (index-- >= 0) {
+#if TCL_UTF_MAX <= 4
+ src += (len = TclUtfToUniChar(src, &ch));
+#else
src += TclUtfToUniChar(src, &ch);
+#endif
+ }
+ fullchar = ch;
+#if TCL_UTF_MAX <= 4
+ if (!len) {
+ /* If last Tcl_UniChar was an upper surrogate, combine with lower surrogate */
+ (void)TclUtfToUniChar(src, &ch);
+ fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
}
- return ch;
+#endif
+ return fullchar;
}
/*
@@ -736,7 +754,9 @@ Tcl_UniCharAtIndex(
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
- * the UTF-8 string.
+ * the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as
+ * 2 positions, but then the pointer should never be placed between
+ * the two positions.
*
* Results:
* As above.
@@ -753,10 +773,18 @@ Tcl_UtfAtIndex(
register int index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
+ int len = 1;
while (index-- > 0) {
+ len = TclUtfToUniChar(src, &ch);
+ src += len;
+ }
+#if TCL_UTF_MAX <= 4
+ if (!len) {
+ /* Index points at character following High Surrogate */
src += TclUtfToUniChar(src, &ch);
}
+#endif
return src;
}
@@ -835,7 +863,8 @@ int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
- Tcl_UniChar ch = 0, upChar;
+ Tcl_UniChar ch = 0;
+ int upChar;
char *src, *dst;
int bytes;
@@ -846,7 +875,16 @@ Tcl_UtfToUpper(
src = dst = str;
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
- upChar = Tcl_UniCharToUpper(ch);
+ upChar = ch;
+#if TCL_UTF_MAX <= 4
+ if (!bytes) {
+ /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+ bytes = TclUtfToUniChar(src, &ch);
+ /* Combine surrogates */
+ upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ upChar = Tcl_UniCharToUpper(upChar);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -888,7 +926,8 @@ int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
- Tcl_UniChar ch = 0, lowChar;
+ Tcl_UniChar ch = 0;
+ int lowChar;
char *src, *dst;
int bytes;
@@ -899,7 +938,16 @@ Tcl_UtfToLower(
src = dst = str;
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
- lowChar = Tcl_UniCharToLower(ch);
+ lowChar = ch;
+#if TCL_UTF_MAX <= 4
+ if (!bytes) {
+ /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+ bytes = TclUtfToUniChar(src, &ch);
+ /* Combine surrogates */
+ lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ lowChar = Tcl_UniCharToLower(lowChar);
/*
* To keep badly formed Utf strings from getting inflated by the
@@ -942,7 +990,8 @@ int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
- Tcl_UniChar ch = 0, titleChar, lowChar;
+ Tcl_UniChar ch = 0;
+ int titleChar, lowChar;
char *src, *dst;
int bytes;
@@ -955,7 +1004,16 @@ Tcl_UtfToTitle(
if (*src) {
bytes = TclUtfToUniChar(src, &ch);
- titleChar = Tcl_UniCharToTitle(ch);
+ titleChar = ch;
+#if TCL_UTF_MAX <= 4
+ if (!bytes) {
+ /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+ bytes = TclUtfToUniChar(src, &ch);
+ /* Combine surrogates */
+ titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ titleChar = Tcl_UniCharToTitle(titleChar);
if (bytes < TclUtfCount(titleChar)) {
memcpy(dst, src, (size_t) bytes);
@@ -967,7 +1025,16 @@ Tcl_UtfToTitle(
}
while (*src) {
bytes = TclUtfToUniChar(src, &ch);
- lowChar = Tcl_UniCharToLower(ch);
+ lowChar = ch;
+#if TCL_UTF_MAX <= 4
+ if (!bytes) {
+ /* TclUtfToUniChar only returns 0 for chars > 0xffff ! */
+ bytes = TclUtfToUniChar(src, &ch);
+ /* Combine surrogates */
+ lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000;
+ }
+#endif
+ lowChar = Tcl_UniCharToLower(lowChar);
if (bytes < TclUtfCount(lowChar)) {
memcpy(dst, src, (size_t) bytes);
@@ -1069,7 +1136,7 @@ Tcl_UtfNcmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1120,7 +1187,7 @@ Tcl_UtfNcasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1169,7 +1236,7 @@ TclUtfCmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1215,7 +1282,7 @@ TclUtfCasecmp(
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
@@ -1252,16 +1319,18 @@ TclUtfCasecmp(
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharToUpper(
int ch) /* Unicode character to convert. */
{
- int info = GetUniCharInfo(ch);
+ if (!UNICODE_OUT_OF_RANGE(ch)) {
+ int info = GetUniCharInfo(ch);
- if (GetCaseType(info) & 0x04) {
- ch -= GetDelta(info);
+ if (GetCaseType(info) & 0x04) {
+ ch -= GetDelta(info);
+ }
}
- return (Tcl_UniChar) ch;
+ return ch & 0x1FFFFF;
}
/*
@@ -1280,16 +1349,18 @@ Tcl_UniCharToUpper(
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharToLower(
int ch) /* Unicode character to convert. */
{
- int info = GetUniCharInfo(ch);
+ if (!UNICODE_OUT_OF_RANGE(ch)) {
+ int info = GetUniCharInfo(ch);
- if (GetCaseType(info) & 0x02) {
- ch += GetDelta(info);
+ if (GetCaseType(info) & 0x02) {
+ ch += GetDelta(info);
+ }
}
- return (Tcl_UniChar) ch;
+ return ch & 0x1FFFFF;
}
/*
@@ -1308,23 +1379,25 @@ Tcl_UniCharToLower(
*----------------------------------------------------------------------
*/
-Tcl_UniChar
+int
Tcl_UniCharToTitle(
int ch) /* Unicode character to convert. */
{
- int info = GetUniCharInfo(ch);
- int mode = GetCaseType(info);
+ if (!UNICODE_OUT_OF_RANGE(ch)) {
+ int info = GetUniCharInfo(ch);
+ int mode = GetCaseType(info);
- if (mode & 0x1) {
- /*
- * Subtract or add one depending on the original case.
- */
+ if (mode & 0x1) {
+ /*
+ * Subtract or add one depending on the original case.
+ */
- ch += ((mode & 0x4) ? -1 : 1);
- } else if (mode == 0x4) {
- ch -= GetDelta(info);
+ ch += ((mode & 0x4) ? -1 : 1);
+ } else if (mode == 0x4) {
+ ch -= GetDelta(info);
+ }
}
- return (Tcl_UniChar) ch;
+ return ch & 0x1FFFFF;
}
/*
@@ -1458,11 +1531,9 @@ int
Tcl_UniCharIsAlnum(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}
@@ -1486,11 +1557,9 @@ int
Tcl_UniCharIsAlpha(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}
@@ -1514,7 +1583,6 @@ int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) {
@@ -1525,7 +1593,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1549,11 +1616,9 @@ int
Tcl_UniCharIsDigit(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}
@@ -1577,12 +1642,10 @@ int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
return (ch >= 0xE0100) && (ch <= 0xE01EF);
}
-#endif
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
@@ -1606,11 +1669,9 @@ int
Tcl_UniCharIsLower(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == LOWERCASE_LETTER);
}
@@ -1634,12 +1695,10 @@ int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
return (ch >= 0xE0100) && (ch <= 0xE01EF);
}
-#endif
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
@@ -1663,11 +1722,9 @@ int
Tcl_UniCharIsPunct(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}
@@ -1691,13 +1748,8 @@ int
Tcl_UniCharIsSpace(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
/* Ignore upper 11 bits. */
ch &= 0x1FFFFF;
-#else
- /* Ignore upper 16 bits. */
- ch &= 0xFFFF;
-#endif
/*
* If the character is within the first 127 characters, just use the
@@ -1706,10 +1758,8 @@ Tcl_UniCharIsSpace(
if (ch < 0x80) {
return TclIsSpaceProc((char) ch);
-#if TCL_UTF_MAX > 3
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
-#endif
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
@@ -1738,11 +1788,9 @@ int
Tcl_UniCharIsUpper(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return (GetCategory(ch) == UPPERCASE_LETTER);
}
@@ -1766,11 +1814,9 @@ int
Tcl_UniCharIsWordChar(
int ch) /* Unicode character to test. */
{
-#if TCL_UTF_MAX > 3
if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
}
-#endif
return ((WORD_BITS >> GetCategory(ch)) & 1);
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index d8e0da4..0f20a64 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -174,9 +174,16 @@ typedef struct ArraySearch {
static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
Tcl_Obj *patternPtr, int includeLinks);
+static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr);
+static void ArrayDoneSearch (Interp *iPtr, Var *varPtr, ArraySearch *searchPtr);
+static Tcl_NRPostProc ArrayForLoopCallback;
+static int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr);
static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr,
Var *varPtr, int flags, int index);
+static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name,
+ Var **varPtrPtr, int *isArrayPtr);
+static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name);
static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp,
Tcl_Obj *namePtr, Tcl_Namespace *contextNsPtr,
int flags);
@@ -189,7 +196,6 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr,
static void UnsetVarStruct(Var *varPtr, Var *arrayPtr,
Interp *iPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, int flags, int index);
-static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj);
/*
* Functions defined in this file that may be exported in the future for use
@@ -287,6 +293,42 @@ TclVarHashCreateVar(
return varPtr;
}
+
+static int
+LocateArray(
+ Tcl_Interp *interp,
+ Tcl_Obj *name,
+ Var **varPtrPtr,
+ int *isArrayPtr)
+{
+ Var *arrayPtr, *varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
+ if (TclCheckArrayTraces(interp, varPtr, arrayPtr, name, -1) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ if (varPtrPtr) {
+ *varPtrPtr = varPtr;
+ }
+ if (isArrayPtr) {
+ *isArrayPtr = varPtr && !TclIsVarUndefined(varPtr)
+ && TclIsVarArray(varPtr);
+ }
+ return TCL_OK;
+}
+
+static int
+NotArrayError(
+ Tcl_Interp *interp,
+ Tcl_Obj *name)
+{
+ const char *nameStr = Tcl_GetString(name);
+
+ Tcl_SetObjResult(interp,
+ Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL);
+ return TCL_ERROR;
+}
/*
*----------------------------------------------------------------------
@@ -2899,173 +2941,307 @@ Tcl_LappendObjCmd(
/*
*----------------------------------------------------------------------
*
- * TclArraySet --
+ * ArrayForObjCmd
+ * ArrayForNRCmd
+ * ArrayForLoopCallback
+ * ArrayObjNext
*
- * Set the elements of an array. If there are no elements to set, create
- * an empty array. This routine is used by the Tcl_ArrayObjCmd and by the
- * TclSetupEnv routine.
+ * These functions implement the "array for" Tcl command.
+ * array for {k v} a {}
+ * The array for command iterates over the array, setting the
+ * the specified loop variables, and executing the body each iteration.
*
- * Results:
- * A standard Tcl result object.
+ * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd().
*
- * Side effects:
- * A variable will be created if one does not already exist.
- * Callers must Incr arrayNameObj if they pland to Decr it.
+ * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr
+ * inside the structure and calls VarHashFirstEntry to start the hash
+ * iteration.
+ *
+ * ArrayForNRCmd() does not execute the body or set the loop variables,
+ * it only initializes the iterator.
+ *
+ * ArrayForLoopCallback() iterates over the entire array, executing
+ * the body each time.
*
*----------------------------------------------------------------------
*/
+static int
+ArrayObjNext(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj, /* array */
+ Var *varPtr, /* array */
+ ArraySearch *searchPtr,
+ Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key
+ * written into, or NULL. */
+ Tcl_Obj **valuePtrPtr /* Pointer to a variable to have the
+ * value written into, or NULL.*/
+ )
+{
+ Tcl_Obj *keyObj;
+ Tcl_Obj *valueObj = NULL;
+ int gotValue;
+ int donerc;
+
+ donerc = TCL_BREAK;
+
+ if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) {
+ donerc = TCL_ERROR;
+ return donerc;
+ }
+
+ gotValue = 0;
+ while (1) {
+ Tcl_HashEntry *hPtr = searchPtr->nextEntry;
+ if (hPtr != NULL) {
+ searchPtr->nextEntry = NULL;
+ } else {
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ gotValue = 0;
+ break;
+ }
+ }
+ varPtr = VarHashGetValue(hPtr);
+ if (!TclIsVarUndefined(varPtr)) {
+ gotValue = 1;
+ break;
+ }
+ }
+
+ if (! gotValue) {
+ return donerc;
+ }
+
+ donerc = TCL_CONTINUE;
+
+ keyObj = VarHashGetKey(varPtr);
+ *keyPtrPtr = keyObj;
+ valueObj = Tcl_ObjGetVar2(interp, arrayNameObj,
+ keyObj, TCL_LEAVE_ERR_MSG);
+ *valuePtrPtr = valueObj;
+
+ return donerc;
+}
+
int
-TclArraySet(
+ArrayForObjCmd(
+ ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
- Tcl_Obj *arrayNameObj, /* The array name. */
- Tcl_Obj *arrayElemObj) /* The array elements list or dict. If this is
- * NULL, create an empty array. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
{
- Var *varPtr, *arrayPtr;
- int result, i;
+ return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv);
+}
- varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
- /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
- /*createPart2*/ 1, &arrayPtr);
- if (varPtr == NULL) {
+static int
+ArrayForNRCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
+ ArraySearch *searchPtr = NULL;
+ Var *varPtr;
+ int isArray, numVars;
+
+ /*
+ * array for {k v} a body
+ */
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "{key value} arrayName script");
return TCL_ERROR;
}
- if (arrayPtr) {
- CleanupVar(varPtr, arrayPtr);
- TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
- TclGetString(arrayNameObj), NULL);
+
+ /*
+ * Parse arguments.
+ */
+
+ if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) {
return TCL_ERROR;
}
- if (arrayElemObj == NULL) {
- goto ensureArray;
+ if (numVars != 2) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "must have two variable names", -1));
+ Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL);
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[2];
+
+ if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
+ }
+
+ if (!isArray) {
+ return NotArrayError(interp, arrayNameObj);
}
/*
- * Install the contents of the dictionary or list into the array.
+ * Make a new array search, put it on the stack.
*/
- if (arrayElemObj->typePtr == &tclDictType) {
- Tcl_Obj *keyPtr, *valuePtr;
- Tcl_DictSearch search;
- int done;
+ searchPtr = ckalloc(sizeof(ArraySearch));
+ ArrayPopulateSearch (interp, arrayNameObj, varPtr, searchPtr);
- if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
- return TCL_ERROR;
- }
- if (done == 0) {
- /*
- * Empty, so we'll just force the array to be properly existing
- * instead.
- */
+ /*
+ * Make sure that these objects (which we need throughout the body of the
+ * loop) don't vanish.
+ */
- goto ensureArray;
- }
+ varListObj = TclListObjCopy(NULL, objv[1]);
+ scriptObj = objv[3];
+ Tcl_IncrRefCount(scriptObj);
- /*
- * Don't need to look at result of Tcl_DictObjFirst as we've just
- * successfully used a dictionary operation on the same object.
- */
+ /*
+ * Run the script.
+ */
- for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
- &keyPtr, &valuePtr, &done) ; !done ;
- Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
- /*
- * At this point, it would be nice if the key was directly usable
- * by the array. This isn't the case though.
- */
+ TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+ arrayNameObj, scriptObj);
+ return TCL_OK;
+}
- Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
- keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+static int
+ArrayForLoopCallback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ ArraySearch *searchPtr = data[0];
+ Tcl_Obj *varListObj = data[1];
+ Tcl_Obj *arrayNameObj = data[2];
+ Tcl_Obj *scriptObj = data[3];
+ Tcl_Obj **varv;
+ Tcl_Obj *keyObj, *valueObj;
+ Var *varPtr;
+ Var *arrayPtr;
+ int done, varc;
- if ((elemVarPtr == NULL) ||
- (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
- keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
- Tcl_DictObjDone(&search);
- return TCL_ERROR;
- }
- }
- return TCL_OK;
- } else {
- /*
- * Not a dictionary, so assume (and convert to, for backward-
- * -compatibility reasons) a list.
- */
+ /*
+ * Process the result from the previous execution of the script body.
+ */
- int elemLen;
- Tcl_Obj **elemPtrs, *copyListObj;
+ done = TCL_ERROR;
- result = TclListObjGetElements(interp, arrayElemObj,
- &elemLen, &elemPtrs);
- if (result != TCL_OK) {
- return result;
- }
- if (elemLen & 1) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "list must have an even number of elements", -1));
- Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
- return TCL_ERROR;
- }
- if (elemLen == 0) {
- goto ensureArray;
+ if (result == TCL_CONTINUE) {
+ result = TCL_OK;
+ } else if (result != TCL_OK) {
+ if (result == TCL_BREAK) {
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"array for\" body line %d)",
+ Tcl_GetErrorLine(interp)));
}
+ goto arrayfordone;
+ }
- /*
- * We needn't worry about traces invalidating arrayPtr: should that be
- * the case, TclPtrSetVarIdx will return NULL so that we break out of
- * the loop and return an error.
- */
+ /*
+ * Get the next mapping from the array.
+ */
- copyListObj = TclListObjCopy(NULL, arrayElemObj);
- for (i=0 ; i<elemLen ; i+=2) {
- Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
- elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+ keyObj = NULL;
+ valueObj = NULL;
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
+ /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ if (varPtr == NULL) {
+ done = TCL_ERROR;
+ } else {
+ done = ArrayObjNext (interp, arrayNameObj, varPtr,
+ searchPtr, &keyObj, &valueObj);
+ }
- if ((elemVarPtr == NULL) ||
- (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
- elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
- result = TCL_ERROR;
- break;
- }
- }
- Tcl_DecrRefCount(copyListObj);
- return result;
+ result = TCL_OK;
+ if (done != TCL_CONTINUE) {
+ Tcl_ResetResult(interp);
+ if (done == TCL_ERROR) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "array changed during iteration", -1));
+ Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL);
+ varPtr->flags |= TCL_LEAVE_ERR_MSG;
+ result = done;
+ }
+ goto arrayfordone;
+ }
+
+ Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv);
+ if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
+ if (valueObj != NULL) {
+ if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ goto arrayfordone;
+ }
}
/*
- * The list is empty make sure we have an array, or create one if
- * necessary.
+ * Run the script.
*/
- ensureArray:
- if (varPtr != NULL) {
- if (TclIsVarArray(varPtr)) {
- /*
- * Already an array, done.
- */
+ TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj,
+ arrayNameObj, scriptObj);
+ return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3);
- return TCL_OK;
- }
- if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
- /*
- * Either an array element, or a scalar: lose!
- */
+ /*
+ * For unwinding everything once the iterating is done.
+ */
- TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
- needArray, -1);
- Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
- return TCL_ERROR;
- }
+ arrayfordone:
+ /* if the search was terminated by an array change, the
+ * VAR_SEARCH_ACTIVE flag will no longer be set
+ */
+ if (done != TCL_ERROR) {
+ ArrayDoneSearch (iPtr, varPtr, searchPtr);
+ Tcl_DecrRefCount(searchPtr->name);
+ ckfree(searchPtr);
}
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
- return TCL_OK;
+
+ TclDecrRefCount(varListObj);
+ TclDecrRefCount(scriptObj);
+ return result;
}
/*
+ * ArrayPopulateSearch
+ */
+static void
+ArrayPopulateSearch(
+ Tcl_Interp *interp,
+ Tcl_Obj *arrayNameObj,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Interp *iPtr = (Interp *)interp;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+
+ hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
+ if (isNew) {
+ searchPtr->id = 1;
+ varPtr->flags |= VAR_SEARCH_ACTIVE;
+ searchPtr->nextPtr = NULL;
+ } else {
+ searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
+ searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
+ }
+ searchPtr->varPtr = varPtr;
+ searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
+ &searchPtr->search);
+ Tcl_SetHashValue(hPtr, searchPtr);
+ searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
+ TclGetString(arrayNameObj));
+ Tcl_IncrRefCount(searchPtr->name);
+}
+/*
*----------------------------------------------------------------------
*
* ArrayStartSearchCmd --
@@ -3085,52 +3261,6 @@ TclArraySet(
/* ARGSUSED */
-static Var *
-VerifyArray(
- Tcl_Interp *interp,
- Tcl_Obj *varNameObj)
-{
- Interp *iPtr = (Interp *) interp;
- const char *varName = TclGetString(varNameObj);
- Var *arrayPtr;
-
- /*
- * Locate the array variable.
- */
-
- Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return NULL;
- }
- }
-
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't an array", varName));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL);
- return NULL;
- }
-
- return varPtr;
-}
-
static int
ArrayStartSearchCmd(
ClientData clientData,
@@ -3138,10 +3268,8 @@ ArrayStartSearchCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
- int isNew;
+ int isArray;
ArraySearch *searchPtr;
if (objc != 2) {
@@ -3149,31 +3277,20 @@ ArrayStartSearchCmd(
return TCL_ERROR;
}
- varPtr = VerifyArray(interp, objv[1]);
- if (varPtr == NULL) {
+ if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
return TCL_ERROR;
}
+ if (!isArray) {
+ return NotArrayError(interp, objv[1]);
+ }
+
/*
* Make a new array search with a free name.
*/
searchPtr = ckalloc(sizeof(ArraySearch));
- hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
- if (isNew) {
- searchPtr->id = 1;
- varPtr->flags |= VAR_SEARCH_ACTIVE;
- searchPtr->nextPtr = NULL;
- } else {
- searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
- searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
- }
- searchPtr->varPtr = varPtr;
- searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
- &searchPtr->search);
- Tcl_SetHashValue(hPtr, searchPtr);
- searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1]));
- Tcl_IncrRefCount(searchPtr->name);
+ ArrayPopulateSearch (interp, objv[1], varPtr, searchPtr);
Tcl_SetObjResult(interp, searchPtr->name);
return TCL_OK;
}
@@ -3181,6 +3298,50 @@ ArrayStartSearchCmd(
/*
*----------------------------------------------------------------------
*
+ * ArrayDoneSearch --
+ *
+ * Removes the search from the hash of active searches.
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+ArrayDoneSearch (
+ Interp *iPtr,
+ Var *varPtr,
+ ArraySearch *searchPtr)
+{
+ Tcl_HashEntry *hPtr;
+ ArraySearch *prevPtr;
+
+ /*
+ * Unhook the search from the list of searches associated with the
+ * variable.
+ */
+
+ hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
+ if (hPtr == NULL) {
+ return;
+ }
+ if (searchPtr == Tcl_GetHashValue(hPtr)) {
+ if (searchPtr->nextPtr) {
+ Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
+ } else {
+ varPtr->flags &= ~VAR_SEARCH_ACTIVE;
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ } else {
+ for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ break;
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ArrayAnyMoreCmd --
*
* This object-based function is invoked to process the "array anymore"
@@ -3206,7 +3367,7 @@ ArrayAnyMoreCmd(
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
- int gotValue;
+ int gotValue, isArray;
ArraySearch *searchPtr;
if (objc != 3) {
@@ -3216,11 +3377,14 @@ ArrayAnyMoreCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
}
+ if (!isArray) {
+ return NotArrayError(interp, varNameObj);
+ }
+
/*
* Get the search.
*/
@@ -3282,6 +3446,7 @@ ArrayNextElementCmd(
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
+ int isArray;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3290,11 +3455,14 @@ ArrayNextElementCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
}
+ if (!isArray) {
+ return NotArrayError(interp, varNameObj);
+ }
+
/*
* Get the search.
*/
@@ -3358,9 +3526,9 @@ ArrayDoneSearchCmd(
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
- Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
- ArraySearch *searchPtr, *prevPtr;
+ ArraySearch *searchPtr;
+ int isArray;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3369,11 +3537,14 @@ ArrayDoneSearchCmd(
varNameObj = objv[1];
searchObj = objv[2];
- varPtr = VerifyArray(interp, varNameObj);
- if (varPtr == NULL) {
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
return TCL_ERROR;
}
+ if (!isArray) {
+ return NotArrayError(interp, varNameObj);
+ }
+
/*
* Get the search.
*/
@@ -3383,27 +3554,7 @@ ArrayDoneSearchCmd(
return TCL_ERROR;
}
- /*
- * Unhook the search from the list of searches associated with the
- * variable.
- */
-
- hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
- if (searchPtr == Tcl_GetHashValue(hPtr)) {
- if (searchPtr->nextPtr) {
- Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
- } else {
- varPtr->flags &= ~VAR_SEARCH_ACTIVE;
- Tcl_DeleteHashEntry(hPtr);
- }
- } else {
- for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
- }
- }
- }
+ ArrayDoneSearch (iPtr, varPtr, searchPtr);
Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
@@ -3434,45 +3585,19 @@ ArrayExistsCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *arrayNameObj;
- int notArray;
+ Interp *iPtr = (Interp *)interp;
+ int isArray;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
return TCL_ERROR;
}
- arrayNameObj = objv[1];
-
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, objv[1], NULL, &isArray)) {
+ return TCL_ERROR;
}
- /*
- * Check whether we've actually got an array variable.
- */
-
- notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr));
- Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]);
+ Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]);
return TCL_OK;
}
@@ -3501,13 +3626,12 @@ ArrayGetCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr, *varPtr2;
+ Var *varPtr, *varPtr2;
Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
Tcl_Obj **nameObjPtr, *patternObj;
Tcl_HashSearch search;
const char *pattern;
- int i, count, result;
+ int i, count, result, isArray;
switch (objc) {
case 2:
@@ -3523,35 +3647,12 @@ ArrayGetCmd(
return TCL_ERROR;
}
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
}
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces. If not an array, it's an empty result.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
+ /* If not an array, it's an empty result. */
+ if (!isArray) {
return TCL_OK;
}
@@ -3689,39 +3790,20 @@ ArrayNamesCmd(
"-exact", "-glob", "-regexp", NULL
};
enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP };
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr, *varPtr2;
- Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj;
+ Var *varPtr, *varPtr2;
+ Tcl_Obj *nameObj, *resultObj, *patternObj;
Tcl_HashSearch search;
const char *pattern = NULL;
- int mode = OPT_GLOB;
+ int isArray, mode = OPT_GLOB;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?");
return TCL_ERROR;
}
- varNameObj = objv[1];
patternObj = (objc > 2 ? objv[objc-1] : NULL);
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
+ return TCL_ERROR;
}
/*
@@ -3733,14 +3815,9 @@ ArrayNamesCmd(
return TCL_ERROR;
}
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces. If not an array, the result is empty.
- */
+ /* If not an array, the result is empty. */
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
+ if (!isArray) {
return TCL_OK;
}
@@ -3877,36 +3954,156 @@ ArraySetCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *arrayNameObj;
+ Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
+ int result, i;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName list");
return TCL_ERROR;
}
+ if (TCL_ERROR == LocateArray(interp, objv[1], NULL, NULL)) {
+ return TCL_ERROR;
+ }
+
+ arrayNameObj = objv[1];
+ varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL,
+ /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
+ /*createPart2*/ 1, &arrayPtr);
+ if (varPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (arrayPtr) {
+ CleanupVar(varPtr, arrayPtr);
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME",
+ TclGetString(arrayNameObj), NULL);
+ return TCL_ERROR;
+ }
+
/*
- * Locate the array variable.
+ * Install the contents of the dictionary or list into the array.
*/
- varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+ arrayElemObj = objv[2];
+ if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) {
+ Tcl_Obj *keyPtr, *valuePtr;
+ Tcl_DictSearch search;
+ int done;
+
+ if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (done == 0) {
+ /*
+ * Empty, so we'll just force the array to be properly existing
+ * instead.
+ */
+
+ goto ensureArray;
+ }
+
+ /*
+ * Don't need to look at result of Tcl_DictObjFirst as we've just
+ * successfully used a dictionary operation on the same object.
+ */
+
+ for (Tcl_DictObjFirst(interp, arrayElemObj, &search,
+ &keyPtr, &valuePtr, &done) ; !done ;
+ Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) {
+ /*
+ * At this point, it would be nice if the key was directly usable
+ * by the array. This isn't the case though.
+ */
+
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+ if ((elemVarPtr == NULL) ||
+ (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
+ keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
+ Tcl_DictObjDone(&search);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+ } else {
+ /*
+ * Not a dictionary, so assume (and convert to, for backward-
+ * -compatibility reasons) a list.
+ */
+
+ int elemLen;
+ Tcl_Obj **elemPtrs, *copyListObj;
+
+ result = TclListObjGetElements(interp, arrayElemObj,
+ &elemLen, &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (elemLen & 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list must have an even number of elements", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "FORMAT", NULL);
+ return TCL_ERROR;
+ }
+ if (elemLen == 0) {
+ goto ensureArray;
+ }
+
+ /*
+ * We needn't worry about traces invalidating arrayPtr: should that be
+ * the case, TclPtrSetVarIdx will return NULL so that we break out of
+ * the loop and return an error.
+ */
+
+ copyListObj = TclListObjCopy(NULL, arrayElemObj);
+ for (i=0 ; i<elemLen ; i+=2) {
+ Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj,
+ elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
+
+ if ((elemVarPtr == NULL) ||
+ (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
+ elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ Tcl_DecrRefCount(copyListObj);
+ return result;
+ }
/*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
+ * The list is empty make sure we have an array, or create one if
+ * necessary.
*/
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
+ ensureArray:
+ if (varPtr != NULL) {
+ if (TclIsVarArray(varPtr)) {
+ /*
+ * Already an array, done.
+ */
+
+ return TCL_OK;
+ }
+ if (TclIsVarArrayElement(varPtr) || !TclIsVarUndefined(varPtr)) {
+ /*
+ * Either an array element, or a scalar: lose!
+ */
+
+ TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set",
+ needArray, -1);
+ Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
return TCL_ERROR;
}
}
-
- return TclArraySet(interp, objv[1], objv[2]);
+ TclSetVarArray(varPtr);
+ varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
+ TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+ return TCL_OK;
}
/*
@@ -3934,47 +4131,23 @@ ArraySizeCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
- Tcl_Obj *varNameObj;
+ Var *varPtr;
Tcl_HashSearch search;
Var *varPtr2;
- int size = 0;
+ int isArray, size = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
return TCL_ERROR;
}
- varNameObj = objv[1];
-
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, objv[1], &varPtr, &isArray)) {
+ return TCL_ERROR;
}
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces. We can only iterate over the array if it exists...
- */
+ /* We can only iterate over the array if it exists... */
- if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) {
+ if (isArray) {
/*
* Must iterate in order to get chance to check for present but
* "undefined" entries.
@@ -4018,10 +4191,10 @@ ArrayStatsCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr;
+ Var *varPtr;
Tcl_Obj *varNameObj;
char *stats;
+ int isArray;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
@@ -4029,40 +4202,12 @@ ArrayStatsCmd(
}
varNameObj = objv[1];
- /*
- * Locate the array variable.
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
}
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "\"%s\" isn't an array", TclGetString(varNameObj)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY",
- TclGetString(varNameObj), NULL);
- return TCL_ERROR;
+ if (!isArray) {
+ return NotArrayError(interp, varNameObj);
}
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
@@ -4101,12 +4246,12 @@ ArrayUnsetCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
- Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr;
+ Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
const char *pattern;
const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */
+ int isArray;
switch (objc) {
case 2:
@@ -4122,35 +4267,11 @@ ArrayUnsetCmd(
return TCL_ERROR;
}
- /*
- * Locate the array variable
- */
-
- varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0,
- /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
-
- /*
- * Special array trace used to keep the env array in sync for array names,
- * array get, etc.
- */
-
- if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY)
- && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
- if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL,
- (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
- TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) {
- return TCL_ERROR;
- }
+ if (TCL_ERROR == LocateArray(interp, varNameObj, &varPtr, &isArray)) {
+ return TCL_ERROR;
}
- /*
- * Verify that it is indeed an array variable. This test comes after the
- * traces - the variable may actually become an array as an effect of said
- * traces.
- */
-
- if ((varPtr == NULL) || !TclIsVarArray(varPtr)
- || TclIsVarUndefined(varPtr)) {
+ if (!isArray) {
return TCL_OK;
}
@@ -4263,6 +4384,7 @@ TclInitArrayCmd(
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0},
+ {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0},
{"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
{"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0},
{"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
@@ -5395,9 +5517,6 @@ DeleteArray(
Tcl_Obj *objPtr;
VarTrace *tracePtr;
- if (varPtr->flags & VAR_SEARCH_ACTIVE) {
- DeleteSearches(iPtr, varPtr);
- }
for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
elPtr != NULL; elPtr = VarHashNextVar(&search)) {
if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
generated by cgit v0.12 at 2024-11-16 22:40:37 (GMT)