summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2017-06-16 20:17:33 (GMT)
committerdgp <dgp@users.sourceforge.net>2017-06-16 20:17:33 (GMT)
commit9f310b9b2ccc538a0ec23c5e78c345ea25e5812c (patch)
tree8af0d2c3a1fa90ba8d2245452267c15e2667850c
parentf042609de58528f349ca4b106f220eea5f59297c (diff)
parentf7860f65a494888a46e377831ba0419de5f364d9 (diff)
downloadtcl-9f310b9b2ccc538a0ec23c5e78c345ea25e5812c.zip
tcl-9f310b9b2ccc538a0ec23c5e78c345ea25e5812c.tar.gz
tcl-9f310b9b2ccc538a0ec23c5e78c345ea25e5812c.tar.bz2
Merge 8.6; update changes.
-rw-r--r--changes2
-rw-r--r--doc/dict.n2
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclClock.c29
-rw-r--r--generic/tclCmdMZ.c2
-rw-r--r--generic/tclDictObj.c6
-rw-r--r--generic/tclExecute.c45
-rw-r--r--generic/tclInt.decls26
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclIntDecls.h37
-rw-r--r--generic/tclStrToD.c2
-rw-r--r--generic/tclStubInit.c5
-rw-r--r--generic/tclTest.c2
-rw-r--r--generic/tclUtf.c27
-rw-r--r--generic/tclVar.c275
-rw-r--r--macosx/tclMacOSXFCmd.c2
-rw-r--r--tests/clock.test80
-rw-r--r--tests/encoding.test20
-rw-r--r--tests/string.test18
-rw-r--r--tests/utf.test53
20 files changed, 495 insertions, 161 deletions
diff --git a/changes b/changes
index ec0aca7..359f8b8 100644
--- a/changes
+++ b/changes
@@ -8781,4 +8781,6 @@ improvements to regexp engine from Postgres (lane,porter,fellows,seltenreich)
2017-06-05 (bug)[67aa9a] Tcl_UtfToUniChar() revised handling invalid UTF-8 (nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
+2017-06-08 (bug)[2738427] Tcl_NumUtfChars() corner case utf-4.9 (nijtmans)
+
--- Released 8.6.7, ????, 2017 --- http://core.tcl.tk/tcl/ for details
diff --git a/doc/dict.n b/doc/dict.n
index fecad85..cd7e94c 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -437,7 +437,7 @@ puts $foo
# prints: \fIa b foo {a b} bar 2 baz 3\fR
.CE
.SH "SEE ALSO"
-append(n), array(n), foreach(n), mapeach(n), incr(n), list(n), lappend(n), set(n)
+append(n), array(n), foreach(n), incr(n), list(n), lappend(n), lmap(n), set(n)
.SH KEYWORDS
dictionary, create, update, lookup, iterate, filter, map
'\" Local Variables:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0486383..14d67f6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3543,7 +3543,7 @@ OldMathFuncProc(
args[k].type = TCL_INT;
break;
}
- if (Tcl_GetWideIntFromObj(interp, valuePtr, &args[k].wideValue)
+ if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue)
== TCL_OK) {
args[k].type = TCL_WIDE_INT;
break;
@@ -3569,7 +3569,7 @@ OldMathFuncProc(
return TCL_ERROR;
}
valuePtr = Tcl_GetObjResult(interp);
- Tcl_GetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
+ TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
Tcl_ResetResult(interp);
break;
}
@@ -7174,7 +7174,7 @@ ExprIsqrtFunc(
}
break;
default:
- if (Tcl_GetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
}
if (w < 0) {
@@ -7617,7 +7617,7 @@ ExprWideFunc(
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
- if (Tcl_GetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
+ if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
/*
* Truncate the bignum; keep only bits in wide int range.
*/
@@ -7628,7 +7628,7 @@ ExprWideFunc(
mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetWideIntFromObj(NULL, objPtr, &wResult);
+ TclGetWideIntFromObj(NULL, objPtr, &wResult);
Tcl_DecrRefCount(objPtr);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 02b2845..bbfc83b 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -91,8 +91,8 @@ static const char *const literals[] = {
* Structure containing the client data for [clock]
*/
-typedef struct ClockClientData {
- int refCount; /* Number of live references. */
+typedef struct {
+ size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
@@ -363,7 +363,7 @@ ClockConvertlocaltoutcObjCmd(
"found in dictionary", -1));
return TCL_ERROR;
}
- if ((Tcl_GetWideIntFromObj(interp, secondsObj,
+ if ((TclGetWideIntFromObj(interp, secondsObj,
&fields.localSeconds) != TCL_OK)
|| (TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK)
|| ConvertLocalToUTC(interp, &fields, objv[2], changeover)) {
@@ -442,7 +442,7 @@ ClockGetdatefieldsObjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "seconds tzdata changeover");
return TCL_ERROR;
}
- if (Tcl_GetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK
+ if (TclGetWideIntFromObj(interp, objv[1], &fields.seconds) != TCL_OK
|| TclGetIntFromObj(interp, objv[3], &changeover) != TCL_OK) {
return TCL_ERROR;
}
@@ -1148,7 +1148,7 @@ LookupLastTransition(
*/
if (Tcl_ListObjIndex(interp, rowv[0], 0, &compObj) != TCL_OK
- || Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
+ || TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
@@ -1171,7 +1171,7 @@ LookupLastTransition(
int m = (l + u + 1) / 2;
if (Tcl_ListObjIndex(interp, rowv[m], 0, &compObj) != TCL_OK ||
- Tcl_GetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
+ TclGetWideIntFromObj(interp, compObj, &compVal) != TCL_OK) {
return NULL;
}
if (tick >= compVal) {
@@ -1521,9 +1521,9 @@ GetJulianDayFromEraYearMonthDay(
* See above bug for details. The casts are necessary.
*/
if (ym1 >= 0)
- ym1o4 = ym1 / 4;
+ ym1o4 = ym1 / 4;
else {
- ym1o4 = - (int) (((unsigned int) -ym1) / 4);
+ ym1o4 = - (int) (((unsigned int) -ym1) / 4);
}
#endif
if (ym1 % 4 < 0) {
@@ -1578,12 +1578,10 @@ static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
- int year;
+ int year = fields->year;
if (fields->era == BCE) {
- year = 1 - fields->year;
- } else {
- year = fields->year;
+ year = 1 - year;
}
if (year%4 != 0) {
return 0;
@@ -1694,7 +1692,7 @@ ThreadSafeLocalTime(
* Get a thread-local buffer to hold the returned time.
*/
- struct tm *tmPtr = Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
+ struct tm *tmPtr = Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
@@ -1950,7 +1948,7 @@ ClockParseformatargsObjCmd(
* Check options.
*/
- if (Tcl_GetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[1], &clockVal) != TCL_OK) {
return TCL_ERROR;
}
if ((saw & (1 << CLOCK_FORMAT_GMT))
@@ -2074,8 +2072,7 @@ ClockDeleteCmdProc(
ClockClientData *data = clientData;
int i;
- data->refCount--;
- if (data->refCount == 0) {
+ if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 885a0bc..3f79ca4 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1646,7 +1646,7 @@ StringIsCmd(
}
break;
case STR_IS_WIDE:
- if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
+ if (TCL_OK == TclGetWideIntFromObj(NULL, objPtr, &w)) {
break;
}
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 87fb333..d15255f 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -3535,7 +3535,7 @@ TclDictWithFinish(
* If the dictionary variable doesn't exist, drop everything silently.
*/
- dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, index);
if (dictPtr == NULL) {
return TCL_OK;
@@ -3618,8 +3618,8 @@ TclDictWithFinish(
* Write back the outermost dictionary to the variable.
*/
- if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr,
- TCL_LEAVE_ERR_MSG, index) == NULL) {
+ if (TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ dictPtr, TCL_LEAVE_ERR_MSG, index) == NULL) {
if (allocdict) {
TclDecrRefCount(dictPtr);
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 6499cf8..761a23e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3321,7 +3321,7 @@ TEBCresume(
*/
DECACHE_STACK_INFO();
- objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
+ objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
@@ -3568,7 +3568,7 @@ TEBCresume(
doCallPtrSetVar:
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
+ objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
@@ -3704,7 +3704,7 @@ TEBCresume(
VarHashRefCount(arrayPtr)++;
}
DECACHE_STACK_INFO();
- objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
+ objResultPtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (TclIsVarInHash(varPtr)) {
@@ -3733,7 +3733,7 @@ TEBCresume(
}
}
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr,
+ objResultPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, objResultPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
@@ -3997,7 +3997,7 @@ TEBCresume(
Tcl_DecrRefCount(incrPtr);
} else {
DECACHE_STACK_INFO();
- objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
+ objResultPtr = TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr,
part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
Tcl_DecrRefCount(incrPtr);
@@ -4152,7 +4152,7 @@ TEBCresume(
slowUnsetScalar:
DECACHE_STACK_INFO();
- if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags,
+ if (TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, flags,
opnd) != TCL_OK && flags) {
goto errorInUnset;
}
@@ -4204,7 +4204,7 @@ TEBCresume(
if (flags & TCL_LEAVE_ERR_MSG) {
goto errorInUnset;
}
- } else if (TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, part2Ptr,
+ } else if (TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, NULL, part2Ptr,
flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
goto errorInUnset;
}
@@ -4261,7 +4261,7 @@ TEBCresume(
varPtr->value.objPtr = NULL;
} else {
DECACHE_STACK_INFO();
- TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
+ TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd);
CACHE_STACK_INFO();
}
NEXT_INST_F(5, 0, 0);
@@ -4477,7 +4477,7 @@ TEBCresume(
if (TclIsVarInHash(otherPtr)) {
VarHashRefCount(otherPtr)++;
}
- } else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0,
+ } else if (TclPtrObjMakeUpvarIdx(interp, otherPtr, NULL, 0,
opnd) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
@@ -6938,7 +6938,7 @@ TEBCresume(
}
} else {
DECACHE_STACK_INFO();
- if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
TRACE_APPEND((
@@ -7109,7 +7109,7 @@ TEBCresume(
}
} else {
DECACHE_STACK_INFO();
- if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR init. index temp %d: %.30s",
@@ -7332,7 +7332,8 @@ TEBCresume(
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2);
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
+ opnd2);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -7406,7 +7407,7 @@ TEBCresume(
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
@@ -7435,7 +7436,8 @@ TEBCresume(
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
+ opnd);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -7544,7 +7546,7 @@ TEBCresume(
} else {
Tcl_IncrRefCount(dictPtr);
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
@@ -7638,7 +7640,7 @@ TEBCresume(
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL,
TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (dictPtr == NULL) {
@@ -7671,7 +7673,7 @@ TEBCresume(
TclObjUnsetVar2(interp,
localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
NULL, 0);
- } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ } else if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
@@ -7698,7 +7700,8 @@ TEBCresume(
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
+ dictPtr = TclPtrGetVarIdx(interp, varPtr, NULL, NULL, NULL, 0,
+ opnd);
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
@@ -7728,8 +7731,8 @@ TEBCresume(
valuePtr = var2Ptr->value.objPtr;
} else {
DECACHE_STACK_INFO();
- valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
- duiPtr->varIndices[i]);
+ valuePtr = TclPtrGetVarIdx(interp, var2Ptr, NULL, NULL, NULL,
+ 0, duiPtr->varIndices[i]);
CACHE_STACK_INFO();
}
if (valuePtr == NULL) {
@@ -7747,7 +7750,7 @@ TEBCresume(
varPtr->value.objPtr = dictPtr;
} else {
DECACHE_STACK_INFO();
- objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ objResultPtr = TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
dictPtr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 4e7e422..2a3d2a0 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1011,6 +1011,32 @@ declare 251 {
int TclRegisterLiteral(void *envPtr,
char *bytes, int length, int flags)
}
+
+# Exporting of the internal API to variables.
+
+declare 252 {
+ Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ const int flags)
+}
+declare 253 {
+ Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ Tcl_Obj *newValuePtr, const int flags)
+}
+declare 254 {
+ Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
+ Tcl_Obj *incrPtr, const int flags)
+}
+declare 255 {
+ int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr,
+ Tcl_Obj *myNamePtr, int myFlags)
+}
+declare 256 {
+ int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr,
+ Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 7b582c0..ed867d8 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3935,20 +3935,21 @@ MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp,
const int flags, const char *msg,
const int createPart1, const int createPart2,
Var *arrayPtr, int index);
-MODULE_SCOPE Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const int flags, int index);
-MODULE_SCOPE Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
const int flags, int index);
-MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr,
const int flags, int index);
-MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr,
- Tcl_Obj *myNamePtr, int myFlags, int index);
-MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr,
+MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp,
+ Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags,
+ int index);
+MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, const int flags,
int index);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index f95f999..eda90b4 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -617,6 +617,28 @@ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags,
/* 251 */
EXTERN int TclRegisterLiteral(void *envPtr, char *bytes,
int length, int flags);
+/* 252 */
+EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags);
+/* 253 */
+EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr,
+ const int flags);
+/* 254 */
+EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr,
+ const int flags);
+/* 255 */
+EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp,
+ Tcl_Var otherPtr, Tcl_Obj *myNamePtr,
+ int myFlags);
+/* 256 */
+EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr,
+ Tcl_Var arrayPtr, Tcl_Obj *part1Ptr,
+ Tcl_Obj *part2Ptr, const int flags);
typedef struct TclIntStubs {
int magic;
@@ -874,6 +896,11 @@ typedef struct TclIntStubs {
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */
+ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
+ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
+ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */
+ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
+ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
@@ -1305,6 +1332,16 @@ extern const TclIntStubs *tclIntStubsPtr;
(tclIntStubsPtr->tclSetSlaveCancelFlags) /* 250 */
#define TclRegisterLiteral \
(tclIntStubsPtr->tclRegisterLiteral) /* 251 */
+#define TclPtrGetVar \
+ (tclIntStubsPtr->tclPtrGetVar) /* 252 */
+#define TclPtrSetVar \
+ (tclIntStubsPtr->tclPtrSetVar) /* 253 */
+#define TclPtrIncrObjVar \
+ (tclIntStubsPtr->tclPtrIncrObjVar) /* 254 */
+#define TclPtrObjMakeUpvar \
+ (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */
+#define TclPtrUnsetVar \
+ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 67b6482..2091928 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1183,9 +1183,9 @@ TclParseNumber(
case sNA:
case sNANPAREN:
case sNANHEX:
+#endif
Tcl_Panic("TclParseNumber: bad acceptState %d parsing '%s'",
acceptState, bytes);
-#endif
case BINARY:
shift = numTrailZeros;
if (!significandOverflow && significandWide != 0 &&
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 5b7a1cd..b185f04 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -560,6 +560,11 @@ static const TclIntStubs tclIntStubs = {
TclDoubleDigits, /* 249 */
TclSetSlaveCancelFlags, /* 250 */
TclRegisterLiteral, /* 251 */
+ TclPtrGetVar, /* 252 */
+ TclPtrSetVar, /* 253 */
+ TclPtrIncrObjVar, /* 254 */
+ TclPtrObjMakeUpvar, /* 255 */
+ TclPtrUnsetVar, /* 256 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index f2dbfc9..e8539e8 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6672,7 +6672,7 @@ TestNumUtfCharsCmd(
int len = -1;
if (objc > 2) {
- (void) Tcl_GetStringFromObj(objv[1], &len);
+ (void) Tcl_GetIntFromObj(interp, objv[2], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 52b4291..b13ad75 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -465,7 +465,6 @@ Tcl_NumUtfChars(
* for strlen(string). */
{
Tcl_UniChar ch;
- register Tcl_UniChar *chPtr = &ch;
register int i;
/*
@@ -478,23 +477,25 @@ Tcl_NumUtfChars(
i = 0;
if (length < 0) {
while (*src != '\0') {
- src += TclUtfToUniChar(src, chPtr);
+ src += TclUtfToUniChar(src, &ch);
i++;
}
+ if (i < 0) i = INT_MAX; /* Bug [2738427] */
} else {
- register int n;
-
- while (length > 0) {
- if (UCHAR(*src) < 0xC0) {
- length--;
- src++;
- } else {
- n = Tcl_UtfToUniChar(src, chPtr);
- length -= n;
- src += n;
- }
+ register const char *endPtr = src + length - TCL_UTF_MAX;
+
+ while (src < endPtr) {
+ src += TclUtfToUniChar(src, &ch);
i++;
}
+ endPtr += TCL_UTF_MAX;
+ while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) {
+ src += TclUtfToUniChar(src, &ch);
+ i++;
+ }
+ if (src < endPtr) {
+ i += endPtr - src;
+ }
}
return i;
}
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 30e2f9b..3dd6790 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1309,7 +1309,7 @@ Tcl_ObjGetVar2(
return NULL;
}
- return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, -1);
}
@@ -1339,6 +1339,52 @@ Tcl_Obj *
TclPtrGetVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
+ Tcl_Var varPtr, /* The variable to be read.*/
+ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the
+ * containing array otherwise. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
+ * TCL_LEAVE_ERR_MSG bits. */
+{
+ if (varPtr == NULL) {
+ Tcl_Panic("varPtr must not be NULL");
+ }
+ if (part1Ptr == NULL) {
+ Tcl_Panic("part1Ptr must not be NULL");
+ }
+ return TclPtrGetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
+ part1Ptr, part2Ptr, flags, -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrGetVarIdx --
+ *
+ * Return the value of a Tcl variable as a Tcl object, given the pointers
+ * to the variable's (and possibly containing array's) VAR structure.
+ *
+ * Results:
+ * The return value points to the current object value of the variable
+ * given by varPtr. If the specified variable doesn't exist, or if there
+ * is a clash in array usage, then NULL is returned and a message will be
+ * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
+ *
+ * Side effects:
+ * The ref count for the returned object is _not_ incremented to reflect
+ * the returned reference; if you want to keep a reference to the object
+ * you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclPtrGetVarIdx(
+ Tcl_Interp *interp, /* Command interpreter in which variable is to
+ * be looked up. */
register Var *varPtr, /* The variable to be read.*/
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
@@ -1678,7 +1724,7 @@ Tcl_ObjSetVar2(
return NULL;
}
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
newValuePtr, flags, -1);
}
@@ -1711,6 +1757,60 @@ Tcl_Obj *
TclPtrSetVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
+ Tcl_Var varPtr, /* Reference to the variable to set. */
+ Tcl_Var arrayPtr, /* Reference to the array containing the
+ * variable, or NULL if the variable is a
+ * scalar. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ Tcl_Obj *newValuePtr, /* New value for variable. */
+ const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and
+ * TCL_LEAVE_ERR_MSG bits. */
+{
+ if (varPtr == NULL) {
+ Tcl_Panic("varPtr must not be NULL");
+ }
+ if (part1Ptr == NULL) {
+ Tcl_Panic("part1Ptr must not be NULL");
+ }
+ if (newValuePtr == NULL) {
+ Tcl_Panic("newValuePtr must not be NULL");
+ }
+ return TclPtrSetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
+ part1Ptr, part2Ptr, newValuePtr, flags, -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrSetVarIdx --
+ *
+ * This function is the same as Tcl_SetVar2Ex above, except that it
+ * requires pointers to the variable's Var structs in addition to the
+ * variable names.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the write operation was disallowed because an array was
+ * expected but not found (or vice versa), then NULL is returned; if the
+ * TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will be
+ * left in the interpreter's result. Note that the returned object may
+ * not be the same one referenced by newValuePtr; this is because
+ * variable traces may modify the variable's value.
+ *
+ * Side effects:
+ * The value of the given variable is set. If either the array or the
+ * entry didn't exist then a new variable is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclPtrSetVarIdx(
+ Tcl_Interp *interp, /* Command interpreter in which variable is to
+ * be looked up. */
register Var *varPtr, /* Reference to the variable to set. */
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
@@ -1953,7 +2053,7 @@ TclIncrObjVar2(
"\n (reading value of variable to increment)");
return NULL;
}
- return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ return TclPtrIncrObjVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
incrPtr, flags, -1);
}
@@ -1986,6 +2086,62 @@ Tcl_Obj *
TclPtrIncrObjVar(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
+ Tcl_Var varPtr, /* Reference to the variable to set. */
+ Tcl_Var arrayPtr, /* Reference to the array containing the
+ * variable, or NULL if the variable is a
+ * scalar. */
+ Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
+ * array (if part2 is non-NULL) or the name of
+ * a variable. */
+ Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
+ * the name of an element in the array
+ * part1Ptr. */
+ Tcl_Obj *incrPtr, /* Increment value. */
+/* TODO: Which of these flag values really make sense? */
+ const int flags) /* Various flags that tell how to incr value:
+ * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
+ * TCL_LEAVE_ERR_MSG. */
+{
+ if (varPtr == NULL) {
+ Tcl_Panic("varPtr must not be NULL");
+ }
+ if (part1Ptr == NULL) {
+ Tcl_Panic("part1Ptr must not be NULL");
+ }
+ return TclPtrIncrObjVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
+ part1Ptr, part2Ptr, incrPtr, flags, -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrIncrObjVarIdx --
+ *
+ * Given the pointers to a variable and possible containing array,
+ * increment the Tcl object value of the variable by a Tcl_Obj increment.
+ *
+ * Results:
+ * Returns a pointer to the Tcl_Obj holding the new value of the
+ * variable. If the specified variable doesn't exist, or there is a clash
+ * in array usage, or an error occurs while executing variable traces,
+ * then NULL is returned and a message will be left in the interpreter's
+ * result.
+ *
+ * Side effects:
+ * The value of the given variable is incremented by the specified
+ * amount. If either the array or the entry didn't exist then a new
+ * variable is created. The ref count for the returned object is _not_
+ * incremented to reflect the returned reference; if you want to keep a
+ * reference to the object you must increment its ref count yourself.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclPtrIncrObjVarIdx(
+ Tcl_Interp *interp, /* Command interpreter in which variable is to
+ * be found. */
Var *varPtr, /* Reference to the variable to set. */
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
@@ -2011,8 +2167,8 @@ TclPtrIncrObjVar(
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
- varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
- flags, index);
+ varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
+ part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
}
@@ -2024,8 +2180,8 @@ TclPtrIncrObjVar(
varValuePtr = Tcl_DuplicateObj(varValuePtr);
if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) {
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
- varValuePtr, flags, index);
+ return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
+ part2Ptr, varValuePtr, flags, index);
} else {
Tcl_DecrRefCount(varValuePtr);
return NULL;
@@ -2041,8 +2197,8 @@ TclPtrIncrObjVar(
* is the way to make that happen.
*/
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
- varValuePtr, flags, index);
+ return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
+ part2Ptr, varValuePtr, flags, index);
} else {
return NULL;
}
@@ -2189,8 +2345,8 @@ TclObjUnsetVar2(
return TCL_ERROR;
}
- return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags,
- -1);
+ return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ flags, -1);
}
/*
@@ -2219,6 +2375,53 @@ int
TclPtrUnsetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
+ Tcl_Var varPtr, /* The variable to be unset. */
+ Tcl_Var arrayPtr, /* NULL for scalar variables, pointer to the
+ * containing array otherwise. */
+ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
+ * the name of a variable. */
+ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
+ * in the array part1. */
+ const int flags) /* OR-ed combination of any of
+ * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * TCL_LEAVE_ERR_MSG. */
+{
+ if (varPtr == NULL) {
+ Tcl_Panic("varPtr must not be NULL");
+ }
+ if (part1Ptr == NULL) {
+ Tcl_Panic("part1Ptr must not be NULL");
+ }
+ return TclPtrUnsetVarIdx(interp, (Var *) varPtr, (Var *) arrayPtr,
+ part1Ptr, part2Ptr, flags, -1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPtrUnsetVarIdx --
+ *
+ * Delete a variable, given the pointers to the variable's (and possibly
+ * containing array's) VAR structure.
+ *
+ * Results:
+ * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
+ * the variable can't be unset. In the event of an error, if the
+ * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
+ * interp's result.
+ *
+ * Side effects:
+ * If varPtr and arrayPtr indicate a local or global variable in interp,
+ * it is deleted. If varPtr is an array reference and part2Ptr is NULL,
+ * then the whole array is deleted.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPtrUnsetVarIdx(
+ Tcl_Interp *interp, /* Command interpreter in which varName is to
+ * be looked up. */
register Var *varPtr, /* The variable to be unset. */
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
@@ -2566,11 +2769,11 @@ Tcl_AppendObjCmd(
/*
* Note that we do not need to increase the refCount of the Var
* pointers: should a trace delete the variable, the return value
- * of TclPtrSetVar will be NULL or emptyObjPtr, and we will not
+ * of TclPtrSetVarIdx will be NULL or emptyObjPtr, and we will not
* access the variable again.
*/
- varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1],
+ varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1],
NULL, objv[i], TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG, -1);
if ((varValuePtr == NULL) ||
(varValuePtr == ((Interp *) interp)->emptyObjPtr)) {
@@ -2650,7 +2853,7 @@ Tcl_LappendObjCmd(
createdNewObj = 0;
/*
- * Protect the variable pointers around the TclPtrGetVar call
+ * Protect the variable pointers around the TclPtrGetVarIdx call
* to insure that they remain valid even if the variable was undefined
* and unused.
*/
@@ -2666,7 +2869,7 @@ Tcl_LappendObjCmd(
if (arrayPtr && TclIsVarInHash(arrayPtr)) {
VarHashRefCount(arrayPtr)++;
}
- varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL,
+ varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL,
TCL_LEAVE_ERR_MSG, -1);
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)--;
@@ -2707,7 +2910,7 @@ Tcl_LappendObjCmd(
* and we didn't create the variable.
*/
- newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL,
+ newValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL,
varValuePtr, TCL_LEAVE_ERR_MSG, -1);
if (newValuePtr == NULL) {
return TCL_ERROR;
@@ -2808,7 +3011,7 @@ TclArraySet(
keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
+ (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) {
Tcl_DictObjDone(&search);
return TCL_ERROR;
@@ -2841,8 +3044,8 @@ TclArraySet(
/*
* We needn't worry about traces invalidating arrayPtr: should that be
- * the case, TclPtrSetVar will return NULL so that we break out of the
- * loop and return an error.
+ * the case, TclPtrSetVarIdx will return NULL so that we break out of
+ * the loop and return an error.
*/
copyListObj = TclListObjCopy(NULL, arrayElemObj);
@@ -2851,7 +3054,7 @@ TclArraySet(
elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1);
if ((elemVarPtr == NULL) ||
- (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj,
+ (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj,
elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){
result = TCL_ERROR;
break;
@@ -4078,8 +4281,8 @@ ArrayUnsetCmd(
if (!varPtr2 || TclIsVarUndefined(varPtr2)) {
return TCL_OK;
}
- return TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj, patternObj,
- unsetFlags, -1);
+ return TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj,
+ patternObj, unsetFlags, -1);
}
/*
@@ -4127,7 +4330,7 @@ ArrayUnsetCmd(
nameObj = VarHashGetKey(varPtr2);
if (Tcl_StringMatch(TclGetString(nameObj), pattern)
- && TclPtrUnsetVar(interp, varPtr2, varPtr, varNameObj,
+ && TclPtrUnsetVarIdx(interp, varPtr2, varPtr, varNameObj,
nameObj, unsetFlags, -1) != TCL_OK) {
/*
* If we incremented a refcount, we must decrement it here as we
@@ -4274,7 +4477,7 @@ ObjMakeUpvar(
}
}
- return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
+ return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index);
}
/*
@@ -4316,17 +4519,32 @@ TclPtrMakeUpvar(
myNamePtr = Tcl_NewStringObj(myName, -1);
Tcl_IncrRefCount(myNamePtr);
}
- result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
+ result = TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags,
+ index);
if (myNamePtr) {
Tcl_DecrRefCount(myNamePtr);
}
return result;
}
+int
+TclPtrObjMakeUpvar(
+ Tcl_Interp *interp, /* Interpreter containing variables. Used for
+ * error messages, too. */
+ Tcl_Var otherPtr, /* Pointer to the variable being linked-to. */
+ Tcl_Obj *myNamePtr, /* Name of variable which will refer to
+ * otherP1/otherP2. Must be a scalar. */
+ int myFlags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+ * indicates scope of myName. */
+{
+ return TclPtrObjMakeUpvarIdx(interp, (Var *) otherPtr, myNamePtr, myFlags,
+ -1);
+}
+
/* Callers must Incr myNamePtr if they plan to Decr it. */
int
-TclPtrObjMakeUpvar(
+TclPtrObjMakeUpvarIdx(
Tcl_Interp *interp, /* Interpreter containing variables. Used for
* error messages, too. */
Var *otherPtr, /* Pointer to the variable being linked-to. */
@@ -4793,8 +5011,9 @@ Tcl_VariableObjCmd(
*/
if (i+1 < objc) { /* A value was specified. */
- varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr,
- NULL, objv[i+1], TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG,-1);
+ varValuePtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr,
+ varNamePtr, NULL, objv[i+1],
+ (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 8ecfd0b..f34b280 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -319,7 +319,7 @@ TclMacOSXSetFileAttribute(
} else {
Tcl_WideInt newRsrcForkSize;
- if (Tcl_GetWideIntFromObj(interp, attributePtr,
+ if (TclGetWideIntFromObj(interp, attributePtr,
&newRsrcForkSize) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/tests/clock.test b/tests/clock.test
index 4e44348..b1afa39 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -35,9 +35,9 @@ testConstraint y2038 \
# TEST PLAN
# clock-1:
-# [clock format] - tests of bad and empty arguments
+# [clock format] - tests of bad and empty arguments
#
-# clock-2
+# clock-2
# formatting of year, month and day of month
#
# clock-3
@@ -195,7 +195,7 @@ namespace eval ::tcl::clock {
l li lii liii liv lv lvi lvii lviii lix
lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
- lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii
+ lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii
lxxxix
xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
c
@@ -271,7 +271,7 @@ test clock-1.3 "clock format - empty val" {
test clock-1.4 "clock format - bad flag" {*}{
-body {
list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode
- }
+ }
-match glob
-result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}}
}
@@ -35221,7 +35221,7 @@ test clock-30.25 {clock add seconds at DST conversion} {
test clock-31.1 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35244,7 +35244,7 @@ test clock-31.1 {system locale} \
test clock-31.2 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35267,7 +35267,7 @@ test clock-31.2 {system locale} \
test clock-31.3 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35290,7 +35290,7 @@ test clock-31.3 {system locale} \
test clock-31.4 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35327,7 +35327,7 @@ test clock-31.4 {system locale} \
test clock-31.5 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35364,7 +35364,7 @@ test clock-31.5 {system locale} \
test clock-31.6 {system locale} \
-constraints win \
- -setup {
+ -setup {
namespace eval ::tcl::clock {
namespace import -force ::testClock::registry
}
@@ -35434,7 +35434,7 @@ test clock-32.1 {scan/format across the Gregorian change} {
}
set problems
} {}
-
+
# Legacy tests
# clock clicks
@@ -35468,7 +35468,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} {
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
- "ok" :
+ "ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
@@ -35480,7 +35480,7 @@ test clock-33.5a {clock tests, millisecond timing test} {
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
- "ok" :
+ "ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
@@ -35804,31 +35804,31 @@ test clock-34.47 {ago with multiple relative units} {
} 180000
test clock-34.48 {more than one ToD} {*}{
- -body {clock scan {10:00 11:00}}
+ -body {clock scan {10:00 11:00}}
-returnCodes error
-result {unable to convert date-time string "10:00 11:00": more than one time of day in string}
}
test clock-34.49 {more than one date} {*}{
- -body {clock scan {1/1/2001 2/2/2002}}
+ -body {clock scan {1/1/2001 2/2/2002}}
-returnCodes error
-result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string}
}
test clock-34.50 {more than one time zone} {*}{
- -body {clock scan {10:00 EST CST}}
+ -body {clock scan {10:00 EST CST}}
-returnCodes error
-result {unable to convert date-time string "10:00 EST CST": more than one time zone in string}
}
test clock-34.51 {more than one weekday} {*}{
- -body {clock scan {Monday Tuesday}}
+ -body {clock scan {Monday Tuesday}}
-returnCodes error
-result {unable to convert date-time string "Monday Tuesday": more than one weekday in string}
}
test clock-34.52 {more than one ordinal month} {*}{
- -body {clock scan {next January next March}}
+ -body {clock scan {next January next March}}
-returnCodes error
-result {unable to convert date-time string "next January next March": more than one ordinal month in string}
}
@@ -35924,7 +35924,7 @@ test clock-38.2 {make sure TZ is not cached after unset} \
}
} \
-result 1
-
+
test clock-39.1 {regression - synonym timezones} {
clock format 0 -format {%H:%M:%S} -timezone :US/Eastern
@@ -35996,7 +35996,7 @@ test clock-44.1 {regression test - time zone name containing hyphen } \
}
} \
-result {12:34:56-0500}
-
+
test clock-45.1 {regression test - time zone containing only two digits} \
-body {
clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z
@@ -36041,7 +36041,7 @@ test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup {
test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \
-body {
- list [catch {
+ list [catch {
clock format -86400 -timezone :localtime -format %Y
} result] $result
} \
@@ -36280,7 +36280,7 @@ test clock-56.1 {use of zoneinfo, version 1} {*}{
}
-result {2004-01-01 00:00:00 MST}
}
-
+
test clock-56.2 {use of zoneinfo, version 2} {*}{
-setup {
clock format [clock seconds]
@@ -36330,7 +36330,7 @@ test clock-56.2 {use of zoneinfo, version 2} {*}{
removeFile PhoenixTwo $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
- }
+ }
-body {
clock format 1072940400 -timezone :Test/PhoenixTwo \
-format {%Y-%m-%d %H:%M:%S %Z}
@@ -36540,7 +36540,7 @@ test clock-56.3 {use of zoneinfo, version 2, Y2038 compliance} {*}{
removeFile TijuanaTwo $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
- }
+ }
-body {
clock format 2224738800 -timezone :Test/TijuanaTwo \
-format {%Y-%m-%d %H:%M:%S %Z}
@@ -36692,7 +36692,7 @@ test clock-56.4 {Bug 3470928} {*}{
removeFile Windhoek $tzdir2
removeDirectory Test $tzdir
removeDirectory zoneinfo
- }
+ }
-result {Sun Jan 08 22:30:06 WAST 2012}
}
@@ -36703,7 +36703,7 @@ test clock-57.1 {clock scan - abbreviated options} {
test clock-58.1 {clock l10n - Japanese localisation} {*}{
-setup {
proc backslashify { string } {
-
+
set retval {}
foreach char [split $string {}] {
scan $char %c ccode
@@ -36809,52 +36809,52 @@ test clock-59.1 {military time zones} {
test clock-60.1 {case insensitive weekday names} {
clock scan "2000-W01 monday" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
test clock-60.2 {case insensitive weekday names} {
clock scan "2000-W01 Monday" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
test clock-60.3 {case insensitive weekday names} {
clock scan "2000-W01 MONDAY" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"]
test clock-60.4 {case insensitive weekday names} {
clock scan "2000-W01 friday" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
test clock-60.5 {case insensitive weekday names} {
clock scan "2000-W01 Friday" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
test clock-60.6 {case insensitive weekday names} {
clock scan "2000-W01 FRIDAY" -gmt true -format "%G-W%V %a"
-} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
+} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"]
test clock-60.7 {case insensitive month names} {
clock scan "1 january 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
test clock-60.8 {case insensitive month names} {
clock scan "1 January 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
test clock-60.9 {case insensitive month names} {
clock scan "1 JANUARY 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"]
test clock-60.10 {case insensitive month names} {
clock scan "1 december 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-60.11 {case insensitive month names} {
clock scan "1 December 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-60.12 {case insensitive month names} {
clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y"
-} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
+} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"]
test clock-61.1 {overflow of a wide integer on output} {*}{
-body {
clock format 0x8000000000000000 -format %s -gmt true
- }
+ }
-result {integer value too large to represent}
-returnCodes error
}
test clock-61.2 {overflow of a wide integer on output} {*}{
-body {
clock format -0x8000000000000001 -format %s -gmt true
- }
+ }
-result {integer value too large to represent}
-returnCodes error
}
diff --git a/tests/encoding.test b/tests/encoding.test
index a359f76..5b3c3e1 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -34,6 +34,7 @@ proc runtests {} {
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
testConstraint exec [llength [info commands exec]]
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
@@ -73,7 +74,7 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
} -constraints {testencoding} -body {
encoding system shiftjis ;# incr ref count
encoding dirs [list [pwd]]
- set x [encoding convertto shiftjis \u4e4e] ;# old one found
+ set x [encoding convertto shiftjis \u4e4e] ;# old one found
encoding system identity
llength shiftjis ;# Shimmer away any cache of Tcl_Encoding
lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
@@ -182,7 +183,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} {
puts -nonewline $f "ab\x8c\xc1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
- fconfigure $f -translation binary -encoding shiftjis
+ fconfigure $f -translation binary -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
@@ -265,7 +266,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding}
makeDirectory tmp
makeDirectory [file join tmp encoding]
set f [open [file join tmp encoding splat.enc] w]
- fconfigure $f -translation binary
+ fconfigure $f -translation binary
puts $f "abcdefghijklmnop"
close $f
encoding convertto splat \u4e4e
@@ -286,11 +287,11 @@ test encoding-12.1 {LoadTableEncoding: normal encoding} {
append x [encoding convertfrom iso8859-3 \xd5]
} "\xd5?\u120"
test encoding-12.2 {LoadTableEncoding: single-byte encoding} {
- set x [encoding convertto iso8859-3 ab\u0120g]
+ set x [encoding convertto iso8859-3 ab\u0120g]
append x [encoding convertfrom iso8859-3 ab\xd5g]
} "ab\xd5gab\u120g"
test encoding-12.3 {LoadTableEncoding: multi-byte encoding} {
- set x [encoding convertto shiftjis ab\u4e4eg]
+ set x [encoding convertto shiftjis ab\u4e4eg]
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
} "ab\x8c\xc1gab\u4e4eg"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
@@ -332,9 +333,14 @@ test encoding-16.1 {UnicodeToUtfProc} {
set val [encoding convertfrom unicode NN]
list $val [format %x [scan $val %c]]
} "\u4e4e 4e4e"
+test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body {
+ set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"]
+ list $val [format %x [scan $val %c]]
+} -result "\U460dc 460dc"
-test encoding-17.1 {UtfToUnicodeProc} {
-} {}
+test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body {
+ encoding convertto unicode "\U460dc"
+} -result "\xd8\xd8\xdc\xdc"
test encoding-18.1 {TableToUtfProc} {
} {}
diff --git a/tests/string.test b/tests/string.test
index 3611753..cc65e67 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -219,7 +219,7 @@ test string-4.14 {string first, negative start index} {
} 1
test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
- # strings was incorrect, leading to an index returned by [string first]
+ # strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
@@ -419,7 +419,7 @@ test string-6.37 {string is double, false on int overflow} -setup {
} -result {1 priorValue}
# string-6.38 removed, underflow on input is no longer an error.
test string-6.39 {string is double, false} {
- # This test is non-portable because IRIX thinks
+ # This test is non-portable because IRIX thinks
# that .e1 is a valid double - this is really a bug
# on IRIX as .e1 should NOT be a valid double
#
@@ -576,12 +576,12 @@ test string-6.85 {string is control} {
} 0
test string-6.86 {string is graph} {
## graph is any print char, except space
- list [string is gra -fail var "0123abc!@#\$\u0100 "] $var
-} {0 12}
+ list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var
+} {0 14}
test string-6.87 {string is print} {
## basically any printable char
- list [string is print -fail var "0123abc!@#\$\u0100 \u0010"] $var
-} {0 13}
+ list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var
+} {0 15}
test string-6.88 {string is punct} {
## any graph char that isn't alnum
list [string is punct -fail var "_!@#\u00beq0"] $var
@@ -901,6 +901,10 @@ test string-10.20 {string map, dictionaries don't alter map ordering} {
set map {aa X a Y}
list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
} {XY XY 2 XY}
+test string-10.20.1 {string map, dictionaries don't alter map ordering} {
+ set map {a X b Y a Z}
+ list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa]
+} {ZZZ XXX 2 XXX}
test string-10.21 {string map, ABR checks} {
string map {longstring foob} long
} long
@@ -1833,7 +1837,7 @@ proc MemStress {args} {
set res {}
foreach body $args {
set end 0
- for {set i 0} {$i < 5} {incr i} {
+ for {set i 0} {$i < 5} {incr i} {
proc MemStress_Body {} $body
uplevel 1 MemStress_Body
rename MemStress_Body {}
diff --git a/tests/utf.test b/tests/utf.test
index a03dd6c..422ab08 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -20,6 +20,9 @@ testConstraint testbytestring [llength [info commands testbytestring]]
catch {unset x}
+# Some tests require support for 4-byte UTF-8 sequences
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
+
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
expr {"\x01" eq [testbytestring "\x01"]}
} 1
@@ -38,6 +41,9 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]}
} 1
+test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints {fullutf testbytestring} -body {
+ expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]}
+} -result 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
@@ -60,9 +66,21 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring "\xE4\xb9\x8e"]
} {1}
-test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
- string length [testbytestring "\xF4\xA2\xA2\xA2"]
+test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
+ string length [testbytestring "\xF0\x90\x80\x80"]
+} -result {1}
+test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body {
+ string length [testbytestring "\xF4\x8F\xBF\xBF"]
+} -result {1}
+test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
+ string length [testbytestring "\xF0\x8F\xBF\xBF"]
+} {4}
+test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
+ string length [testbytestring "\xF4\x90\x80\x80"]
} {4}
+test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
+ string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"]
+} {5}
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
@@ -81,17 +99,24 @@ test utf-4.4 {Tcl_NumUtfChars: #u0000} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
- testnumutfchars "" 1
+ testnumutfchars "" 0
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
- testnumutfchars [testbytestring "\xC2\xA2"] 1
+ testnumutfchars [testbytestring "\xC2\xA2"] 2
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
- testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
+ testnumutfchars [testbytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 10
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} {testnumutfchars testbytestring} {
- testnumutfchars [testbytestring "\xC0\x80"] 1
+ testnumutfchars [testbytestring "\xC0\x80"] 2
} {1}
+# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
+test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xE2\x82\xAC"] 2
+} {2}
+test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\x00"] 2
+} {2}
test utf-5.1 {Tcl_UtfFindFirsts} {
} {}
@@ -195,8 +220,16 @@ bsCheck \Ua1 161
bsCheck \U4e21 20001
bsCheck \U004e21 20001
bsCheck \U00004e21 20001
-bsCheck \U00110000 65533
-bsCheck \Uffffffff 65533
+bsCheck \U0000004e21 78
+if {[testConstraint fullutf]} {
+ bsCheck \U00110000 69632
+ bsCheck \U01100000 69632
+ bsCheck \U11000000 69632
+ bsCheck \U0010FFFF 1114111
+ bsCheck \U010FFFF0 1114111
+ bsCheck \U10FFFF00 1114111
+ bsCheck \UFFFFFFFF 1048575
+}
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
@@ -264,8 +297,8 @@ test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
- string tolower \u0178\u00ff\uA78D\u01c5
-} \u00ff\u00ff\u0265\u01c6
+ string tolower \u0178\u00ff\uA78D\u01c5\U10400
+} \u00ff\u00ff\u0265\u01c6\U10428
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !