summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--doc/dict.n2
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclClock.c22
-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/tclStringObj.c109
-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.test10
-rw-r--r--tests/string.test53
-rw-r--r--tests/utf.test53
-rw-r--r--unix/tclUnixSock.c6
21 files changed, 614 insertions, 173 deletions
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 88941dd..0ac62d9 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3566,7 +3566,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;
@@ -3592,7 +3592,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;
}
@@ -7209,7 +7209,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) {
@@ -7670,7 +7670,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.
*/
@@ -7681,7 +7681,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 8423ce6..7f4f592 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -91,7 +91,7 @@ static const char *const literals[] = {
* Structure containing the client data for [clock]
*/
-typedef struct ClockClientData {
+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;
@@ -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))
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 6b14fb7..b81b6e5 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1565,7 +1565,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 57d0798..f4e15a6 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -3583,7 +3583,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;
@@ -3666,8 +3666,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 d2e9b4a..8389bef 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -3192,7 +3192,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) {
@@ -3439,7 +3439,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) {
@@ -3575,7 +3575,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)) {
@@ -3604,7 +3604,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) {
@@ -3868,7 +3868,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);
@@ -4023,7 +4023,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;
}
@@ -4075,7 +4075,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;
}
@@ -4132,7 +4132,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);
@@ -4348,7 +4348,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;
@@ -6770,7 +6770,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((
@@ -6941,7 +6941,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",
@@ -7164,7 +7164,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) {
@@ -7238,7 +7239,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);
@@ -7267,7 +7268,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) {
@@ -7376,7 +7378,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);
@@ -7479,7 +7481,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) {
@@ -7512,7 +7514,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();
@@ -7539,7 +7541,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) {
@@ -7569,8 +7572,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) {
@@ -7588,7 +7591,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 8314925..dea698c 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1011,6 +1011,32 @@ declare 251 {
int TclRegisterLiteral(void *envPtr,
const 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 7e71401..1675fd9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3985,20 +3985,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 dfa5727..5bccfe5 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, const 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, const 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 c7fdc5a..57c24ac 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1190,9 +1190,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/tclStringObj.c b/generic/tclStringObj.c
index d40c5e0..92cb137 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2847,9 +2847,11 @@ TclStringCatObjv(
Tcl_Obj * const objv[],
Tcl_Obj **objPtrPtr)
{
- Tcl_Obj *objPtr, *objResultPtr, * const *ov;
- int oc, length = 0, binary = 1, first = 0, last = 0;
+ Tcl_Obj *objResultPtr, * const *ov;
+ int oc, length = 0, binary = 1;
int allowUniChar = 1, requestUniChar = 0;
+ int first = objc - 1; /* Index of first value possibly not empty */
+ int last = 0; /* Index of last value possibly not empty */
/* assert ( objc >= 0 ) */
@@ -2870,7 +2872,7 @@ TclStringCatObjv(
ov = objv, oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes) {
/* Value has a string rep. */
@@ -2906,7 +2908,7 @@ TclStringCatObjv(
/* Result will be pure byte array. Pre-size it */
ov = objv; oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL) {
int numBytes;
@@ -2916,10 +2918,10 @@ TclStringCatObjv(
last = objc - oc;
if (length == 0) {
first = last;
- }
- if ((length += numBytes) < 0) {
+ } else if (numBytes > INT_MAX - length) {
goto overflow;
}
+ length += numBytes;
}
}
} while (--oc);
@@ -2927,7 +2929,7 @@ TclStringCatObjv(
/* Result will be pure Tcl_UniChar array. Pre-size it. */
ov = objv; oc = objc;
do {
- objPtr = *ov++;
+ Tcl_Obj *objPtr = *ov++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int numChars;
@@ -2937,10 +2939,10 @@ TclStringCatObjv(
last = objc - oc;
if (length == 0) {
first = last;
- }
- if ((length += numChars) < 0) {
+ } else if (numChars > INT_MAX - length) {
goto overflow;
}
+ length += numChars;
}
}
} while (--oc);
@@ -2948,26 +2950,91 @@ TclStringCatObjv(
/* Result will be concat of string reps. Pre-size it. */
ov = objv; oc = objc;
do {
+ Tcl_Obj *pendingPtr = NULL;
+
+ /*
+ * Loop until a possibly non-empty value is reached.
+ * Keep string rep generation pending when possible.
+ */
+
+ do {
+ /* assert ( pendingPtr == NULL ) */
+ /* assert ( length == 0 ) */
+
+ Tcl_Obj *objPtr = *ov++;
+
+ if (objPtr->bytes == NULL) {
+ /* No string rep; Take the chance we can avoid making it */
+ pendingPtr = objPtr;
+ } else {
+ Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
+ }
+ } while (--oc && (length == 0) && (pendingPtr == NULL));
+
+ /*
+ * Either we found a possibly non-empty value, and we
+ * remember this index as the first and last such value so
+ * far seen, or (oc == 0) and all values are known empty,
+ * so first = last = objc - 1 signals the right quick return.
+ */
+
+ first = last = objc - oc - 1;
+
+ if (oc && (length == 0)) {
+ int numBytes;
+
+ /* assert ( pendingPtr != NULL ) */
+
+ /*
+ * There's a pending value followed by more values.
+ * Loop over remaining values generating strings until
+ * a non-empty value is found, or the pending value gets
+ * its string generated.
+ */
+
+ do {
+ Tcl_Obj *objPtr = *ov++;
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
+
+ if (numBytes) {
+ last = objc -oc -1;
+ }
+ if (oc || numBytes) {
+ Tcl_GetStringFromObj(pendingPtr, &length);
+ }
+ if (length == 0) {
+ if (numBytes) {
+ first = last;
+ }
+ } else if (numBytes > INT_MAX - length) {
+ goto overflow;
+ }
+ length += numBytes;
+ }
+ } while (oc && (length == 0));
+
+ while (oc) {
int numBytes;
+ Tcl_Obj *objPtr = *ov++;
- objPtr = *ov++;
+ /* assert ( length > 0 && pendingPtr == NULL ) */
- Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
if (numBytes) {
last = objc - oc;
- if (length == 0) {
- first = last;
- }
- if ((length += numBytes) < 0) {
+ if (numBytes > INT_MAX - length) {
goto overflow;
}
+ length += numBytes;
}
- } while (--oc);
+ --oc;
+ }
}
- if (last == first /*|| length == 0 */) {
+ if (last <= first /*|| length == 0 */) {
/* Only one non-empty value or zero length; return first */
- /* NOTE: (length == 0) implies (last == first) */
+ /* NOTE: (length == 0) implies (last <= first) */
*objPtrPtr = objv[first];
return TCL_OK;
}
@@ -3073,9 +3140,9 @@ TclStringCatObjv(
return TCL_ERROR;
}
dst = Tcl_GetString(objResultPtr) + start;
- if (length > start) {
- TclFreeIntRep(objResultPtr);
- }
+
+ /* assert ( length > start ) */
+ TclFreeIntRep(objResultPtr);
} else {
objResultPtr = Tcl_NewObj(); /* PANIC? */
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index be8537d..8ff6291 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -664,6 +664,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 54deaea..47c572f 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6836,7 +6836,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 c46d250..161a4bd 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -459,7 +459,6 @@ Tcl_NumUtfChars(
* for strlen(string). */
{
Tcl_UniChar ch;
- register Tcl_UniChar *chPtr = &ch;
register int i;
/*
@@ -472,23 +471,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 9c3e584..4c3d4a1 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1279,7 +1279,7 @@ Tcl_ObjGetVar2(
return NULL;
}
- return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ return TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
flags, -1);
}
@@ -1309,6 +1309,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. */
@@ -1646,7 +1692,7 @@ Tcl_ObjSetVar2(
return NULL;
}
- return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ return TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
newValuePtr, flags, -1);
}
@@ -1679,6 +1725,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
@@ -1921,7 +2021,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);
}
@@ -1954,6 +2054,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
@@ -1979,8 +2135,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)--;
}
@@ -1992,8 +2148,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;
@@ -2009,8 +2165,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;
}
@@ -2159,8 +2315,8 @@ TclObjUnsetVar2(
return TCL_ERROR;
}
- return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags,
- -1);
+ return TclPtrUnsetVarIdx(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+ flags, -1);
}
/*
@@ -2189,6 +2345,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. */
@@ -2536,11 +2739,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)) {
@@ -2620,7 +2823,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.
*/
@@ -2636,7 +2839,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)--;
@@ -2677,7 +2880,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;
@@ -2778,7 +2981,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;
@@ -2811,8 +3014,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);
@@ -2821,7 +3024,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;
@@ -3969,8 +4172,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);
}
/*
@@ -4018,7 +4221,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
@@ -4165,7 +4368,7 @@ ObjMakeUpvar(
}
}
- return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index);
+ return TclPtrObjMakeUpvarIdx(interp, otherPtr, myNamePtr, myFlags, index);
}
/*
@@ -4207,17 +4410,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. */
@@ -4686,8 +4904,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 f3a2117..f09a441 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 49555b6..be1f4d5 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 testgetencpath [llength [info commands testgetencpath]]
@@ -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 11cbcff..7b02928 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -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
@@ -1994,6 +1994,51 @@ test string-29.4 {string cat, many args} {
set r2 [string compare $xx [eval "string cat $vvs"]]
list $r1 $r2
} {0 0}
+test string-29.5 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list x] [list]]
+} -match glob -result {*no string representation}
+test string-29.6 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list] [list x]]
+} -match glob -result {*no string representation}
+test string-29.7 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list x] [list] [list]]
+} -match glob -result {*no string representation}
+test string-29.8 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list] [list x] [list]]
+} -match glob -result {*no string representation}
+test string-29.9 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list] [list] [list x]]
+} -match glob -result {*no string representation}
+test string-29.10 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat [list x] [list x]]
+} -match glob -result {*, string representation "xx"}
+test string-29.11 {string cat, efficiency} -body {
+ tcl::unsupported::representation \
+ [string cat [list x] [encoding convertto utf-8 {}]]
+} -match glob -result {*no string representation}
+test string-29.12 {string cat, efficiency} -body {
+ tcl::unsupported::representation \
+ [string cat [encoding convertto utf-8 {}] [list x]]
+} -match glob -result {*, string representation "x"}
+test string-29.13 {string cat, efficiency} -body {
+ tcl::unsupported::representation [string cat \
+ [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]]
+} -match glob -result {*, string representation "x"}
+test string-29.14 {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e
+} -body {
+ tcl::unsupported::representation [string cat $e $e [list x]]
+} -match glob -result {*no string representation}
+test string-29.15 {string cat, efficiency} -setup {
+ set e [encoding convertto utf-8 {}]
+ set f [encoding convertto utf-8 {}]
+} -cleanup {
+ unset e f
+} -body {
+ tcl::unsupported::representation [string cat $e $f $e $f [list x]]
+} -match glob -result {*no string representation}
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 !
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index b21deae..c16a482 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -733,6 +733,8 @@ TcpClose2Proc(
*/
#ifndef NEED_FAKE_RFC2553
+#pragma GCC diagnostic push
+#pragma GCC diagnostic ignored "-Wstrict-aliasing"
static inline int
IPv6AddressNeedsNumericRendering(
struct in6_addr addr)
@@ -746,16 +748,14 @@ IPv6AddressNeedsNumericRendering(
* at least some versions of OSX.
*/
-#pragma GCC diagnostic push
-#pragma GCC diagnostic ignored "-Wstrict-aliasing"
if (!IN6_IS_ADDR_V4MAPPED(&addr)) {
-#pragma GCC diagnostic pop
return 0;
}
return (addr.s6_addr[12] == 0 && addr.s6_addr[13] == 0
&& addr.s6_addr[14] == 0 && addr.s6_addr[15] == 0);
}
+#pragma GCC diagnostic pop
#endif /* NEED_FAKE_RFC2553 */
static void
generated by cgit v0.12 at 2024-11-10 19:32:10 (GMT)