summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdMZ.c8
-rw-r--r--generic/tclCompCmds.c18
-rw-r--r--generic/tclExecute.c19
-rw-r--r--generic/tclInt.h4
-rw-r--r--generic/tclStringObj.c6
-rw-r--r--generic/tclTrace.c53
-rw-r--r--generic/tclUtf.c68
-rw-r--r--generic/tclVar.c659
-rw-r--r--library/http/http.tcl7
-rw-r--r--library/http/pkgIndex.tcl2
-rw-r--r--tests/msgcat.test16
-rw-r--r--tests/var.test34
-rw-r--r--unix/Makefile.in4
-rw-r--r--win/Makefile.in4
14 files changed, 380 insertions, 522 deletions
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index d2304b2..6aaf1de 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;
@@ -1444,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));
@@ -1807,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/tclExecute.c b/generic/tclExecute.c
index 5a1966f..35743a1 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4015,17 +4015,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);
@@ -5297,7 +5292,7 @@ TEBCresume(
objResultPtr = Tcl_NewStringObj((const char *)
valuePtr->bytes+index, 1);
} else {
- char buf[TCL_UTF_MAX];
+ char buf[4];
int ch = Tcl_GetUniChar(valuePtr, index);
/*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 27e7ce8..e9afbbb 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 c09457d..5915ce0 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -526,7 +526,7 @@ Tcl_GetUniChar(
return -1;
}
ch = stringPtr->unicode[index];
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* See: bug [11ae2be95dac9417] */
if ((ch&0xF800) == 0xD800) {
if (ch&0x400) {
@@ -703,7 +703,7 @@ Tcl_GetRange(
if (last < first) {
return Tcl_NewObj();
}
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
/* See: bug [11ae2be95dac9417] */
if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
@@ -1978,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 ab4e142..33c22e0 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,7 +142,6 @@ Tcl_UniCharToUtf(
return 2;
}
if (ch <= 0xFFFF) {
-#if TCL_UTF_MAX == 4
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x0400) {
/* Low surrogate */
@@ -167,11 +164,8 @@ Tcl_UniCharToUtf(
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);
@@ -179,7 +173,6 @@ Tcl_UniCharToUtf(
buf[0] = (char) ((ch >> 18) | 0xF0);
return 4;
}
-#endif
}
ch = 0xFFFD;
@@ -349,17 +342,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)
@@ -571,7 +554,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;
@@ -619,7 +602,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;
@@ -662,7 +645,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);
}
@@ -744,19 +727,19 @@ Tcl_UniCharAtIndex(
{
Tcl_UniChar ch = 0;
int fullchar = 0;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
int len = 1;
#endif
while (index-- >= 0) {
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
src += (len = TclUtfToUniChar(src, &ch));
#else
src += TclUtfToUniChar(src, &ch);
#endif
}
fullchar = ch;
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX <= 4
if (!len) {
/* If last Tcl_UniChar was an upper surrogate, combine with lower surrogate */
(void)TclUtfToUniChar(src, &ch);
@@ -1136,7 +1119,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) {
@@ -1187,7 +1170,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) {
@@ -1236,7 +1219,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) {
@@ -1282,7 +1265,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) {
@@ -1531,11 +1514,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);
}
@@ -1559,11 +1540,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);
}
@@ -1587,7 +1566,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))) {
@@ -1598,7 +1576,6 @@ Tcl_UniCharIsControl(
}
return 0;
}
-#endif
return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}
@@ -1622,11 +1599,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);
}
@@ -1650,12 +1625,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);
}
@@ -1679,11 +1652,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);
}
@@ -1707,12 +1678,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);
}
@@ -1736,11 +1705,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);
}
@@ -1764,13 +1731,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
@@ -1779,10 +1741,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;
@@ -1811,11 +1771,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);
}
@@ -1839,11 +1797,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 9405fd5..9422beb 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -177,6 +177,9 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr,
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 +192,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
@@ -248,6 +250,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;
+}
/*
*----------------------------------------------------------------------
@@ -2867,175 +2905,6 @@ Tcl_LappendObjCmd(
/*
*----------------------------------------------------------------------
*
- * TclArraySet --
- *
- * 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.
- *
- * Results:
- * A standard Tcl result object.
- *
- * Side effects:
- * A variable will be created if one does not already exist.
- * Callers must Incr arrayNameObj if they pland to Decr it.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclArraySet(
- 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. */
-{
- Var *varPtr, *arrayPtr;
- int result, i;
-
- 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;
- }
-
- if (arrayElemObj == NULL) {
- goto ensureArray;
- }
-
- /*
- * Install the contents of the dictionary or list into the array.
- */
-
- if (arrayElemObj->typePtr == &tclDictType) {
- 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;
- }
-
- /*
- * The list is empty make sure we have an array, or create one if
- * necessary.
- */
-
- 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;
- }
- }
- TclSetVarArray(varPtr);
- varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
- TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* ArrayStartSearchCmd --
*
* This object-based function is invoked to process the "array
@@ -3053,52 +2922,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,
@@ -3106,26 +2929,31 @@ ArrayStartSearchCmd(
int objc,
Tcl_Obj *const objv[])
{
- Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *)interp;
Var *varPtr;
Tcl_HashEntry *hPtr;
- int isNew;
+ int isNew, isArray;
ArraySearch *searchPtr;
+ const char *varName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName");
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.
*/
+ varName = TclGetString(objv[1]);
searchPtr = ckalloc(sizeof(ArraySearch));
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
@@ -3174,7 +3002,7 @@ ArrayAnyMoreCmd(
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
- int gotValue;
+ int gotValue, isArray;
ArraySearch *searchPtr;
if (objc != 3) {
@@ -3184,11 +3012,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.
*/
@@ -3250,6 +3081,7 @@ ArrayNextElementCmd(
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
+ int isArray;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3258,11 +3090,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.
*/
@@ -3329,6 +3164,7 @@ ArrayDoneSearchCmd(
Tcl_HashEntry *hPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr, *prevPtr;
+ int isArray;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId");
@@ -3337,11 +3173,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.
*/
@@ -3402,45 +3241,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;
}
@@ -3469,13 +3282,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:
@@ -3491,35 +3303,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;
}
@@ -3657,39 +3446,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;
}
/*
@@ -3701,14 +3471,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;
}
@@ -3845,36 +3610,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;
}
/*
@@ -3902,47 +3787,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.
@@ -3986,10 +3847,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");
@@ -3997,40 +3858,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);
@@ -4069,12 +3902,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:
@@ -4090,35 +3923,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;
}
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 9f5310b..186d067 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.6-
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.8.12
+package provide http 2.8.13
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -602,7 +602,7 @@ proc http::geturl {url args} {
if {[info exists state(-myaddr)]} {
lappend sockopts -myaddr $state(-myaddr)
}
- if {[catch {eval $defcmd $sockopts $targetAddr} sock]} {
+ if {[catch {eval $defcmd $sockopts $targetAddr} sock errdict]} {
# something went wrong while trying to establish the connection.
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
@@ -611,7 +611,8 @@ proc http::geturl {url args} {
set state(sock) $sock
Finish $token "" 1
cleanup $token
- return -code error $sock
+ dict unset errdict -level
+ return -options $errdict $sock
}
}
set state(sock) $sock
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index d3fc7af..3324af9 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
-package ifneeded http 2.8.12 [list tclPkgSetup $dir http 2.8.12 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.8.13 [list tclPkgSetup $dir http 2.8.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 0d2f928..12030fb 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -1317,33 +1317,33 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
interp bgerror {} $bgerrorsaved
- # Tests msgcat-15.*: [mcutil]
+ # Tests msgcat-18.*: [mcutil]
- test msgcat-15.1 {mcutil - no argument} -body {
+ test msgcat-18.1 {mcutil - no argument} -body {
mcutil
} -returnCodes 1\
-result {wrong # args: should be "mcutil subcommand ?arg ...?"}
- test msgcat-15.2 {mcutil - wrong argument} -body {
+ test msgcat-18.2 {mcutil - wrong argument} -body {
mcutil junk
} -returnCodes 1\
-result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
- test msgcat-15.3 {mcutil - partial argument} -body {
+ test msgcat-18.3 {mcutil - partial argument} -body {
mcutil getsystem
} -returnCodes 1\
-result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
- test msgcat-15.4 {mcutil getpreferences - no argument} -body {
+ test msgcat-18.4 {mcutil getpreferences - no argument} -body {
mcutil getpreferences
} -returnCodes 1\
-result {wrong # args: should be "mcutil getpreferences locale"}
- test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
+ test msgcat-18.5 {mcutil getpreferences - DE_de} -body {
mcutil getpreferences DE_de
} -result {de_de de {}}
- test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
+ test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body {
mcutil getsystemlocale DE_de
} -returnCodes 1\
-result {wrong # args: should be "mcutil getsystemlocale"}
@@ -1351,7 +1351,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} {
# The result is system dependent
# So just test if it runs
# The environment variable version was test with test 0.x
- test msgcat-15.7 {mcutil getsystemlocale} -body {
+ test msgcat-18.7 {mcutil getsystemlocale} -body {
mcutil getsystemlocale
set ok ok
} -result {ok}
diff --git a/tests/var.test b/tests/var.test
index 9816d98..5059e9e 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -820,6 +820,18 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup {
} -cleanup {
unset -nocomplain ::a ::elements
} -result {}
+test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup {
+ unset -nocomplain a d
+ set d {p 1 p 2}
+ dict get $d p
+ set foo 0
+} -body {
+ trace add variable a write "[list incr [namespace which -variable foo]];#"
+ array set a $d
+ set foo
+} -cleanup {
+ unset -nocomplain a d foo
+} -result 2
test var-18.1 {array unset and unset traces: Bug 2939073} -setup {
set already 0
@@ -931,6 +943,28 @@ test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup {
test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body {
apply {{} {set name foo(bar); array set $name {a 1}}}
} -returnCodes error -match glob -result *
+test var-20.11 {array set don't compile bad initializer} -setup {
+ unset -nocomplain foo
+ trace add variable foo array {set foo(bar) baz;#}
+} -body {
+ catch {array set foo bad}
+ set foo(bar)
+} -cleanup {
+ unset -nocomplain foo
+} -result baz
+test var-20.12 {array set don't compile bad initializer} -setup {
+ unset -nocomplain ::foo
+ trace add variable ::foo array {set ::foo(bar) baz;#}
+} -body {
+ catch {apply {{} {
+ set value bad
+ array set ::foo $value
+
+ }}}
+ set ::foo(bar)
+} -cleanup {
+ unset -nocomplain ::foo
+} -result baz
test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup {
proc linenumber {} {dict get [info frame -1] line}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 83a8aed..51c06e5 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -844,8 +844,8 @@ install-libraries: libraries
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing package http 2.8.12 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm;
+ @echo "Installing package http 2.8.13 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.13.tm;
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
@for i in $(TOP_DIR)/library/opt/*.tcl ; \
do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 56ccb4d..6326075 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -653,8 +653,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing package http 2.8.12 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm;
+ @echo "Installing package http 2.8.13 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.13.tm;
@echo "Installing library opt0.4 directory";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
generated by cgit v0.12 at 2025-12-08 00:46:45 (GMT)