From 4cf238f3c3fd4ef9aed542f0f5f55a4dff225cd9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 6 Jun 2017 17:51:12 +0000
Subject: Expose some of the core variable access APIs. (Cherrypick from
[b4dfc30083])
---
generic/tclDictObj.c | 6 +-
generic/tclExecute.c | 45 +++++----
generic/tclInt.decls | 26 +++++
generic/tclInt.h | 13 +--
generic/tclIntDecls.h | 37 +++++++
generic/tclStubInit.c | 5 +
generic/tclVar.c | 275 +++++++++++++++++++++++++++++++++++++++++++++-----
7 files changed, 349 insertions(+), 58 deletions(-)
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/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/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;
}
--
cgit v0.12
From 9562ecd7fa7b25bf6e8e37f5977c81336fd46c06 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 8 Jun 2017 11:48:13 +0000
Subject: tclUtil.c: Use TclUtfToUniChar() in stead of handling ASCII
characters separately: This macro already does that. Add new test-case for
Tcl_NumUtfChars(), for a knownBug still to be fixed.
---
generic/tclTest.c | 2 +-
generic/tclUtil.c | 47 ++++++++++++-----------------------------------
tests/utf.test | 11 +++++++----
3 files changed, 20 insertions(+), 40 deletions(-)
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/tclUtil.c b/generic/tclUtil.c
index 553593c..3fdf54b 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2162,14 +2162,9 @@ Tcl_StringCaseMatch(
* This is a special case optimization for single-byte utf.
*/
- if (UCHAR(*pattern) < 0x80) {
- ch2 = (Tcl_UniChar)
- (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
- } else {
- Tcl_UtfToUniChar(pattern, &ch2);
- if (nocase) {
- ch2 = Tcl_UniCharToLower(ch2);
- }
+ TclUtfToUniChar(pattern, &ch2);
+ if (nocase) {
+ ch2 = Tcl_UniCharToLower(ch2);
}
while (1) {
@@ -2235,44 +2230,26 @@ Tcl_StringCaseMatch(
Tcl_UniChar startChar, endChar;
pattern++;
- if (UCHAR(*str) < 0x80) {
- ch1 = (Tcl_UniChar)
- (nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
- str++;
- } else {
- str += Tcl_UtfToUniChar(str, &ch1);
- if (nocase) {
- ch1 = Tcl_UniCharToLower(ch1);
- }
+ str += TclUtfToUniChar(str, &ch1);
+ if (nocase) {
+ ch1 = Tcl_UniCharToLower(ch1);
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
- if (UCHAR(*pattern) < 0x80) {
- startChar = (Tcl_UniChar) (nocase
- ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
- pattern++;
- } else {
- pattern += Tcl_UtfToUniChar(pattern, &startChar);
- if (nocase) {
- startChar = Tcl_UniCharToLower(startChar);
- }
+ pattern += TclUtfToUniChar(pattern, &startChar);
+ if (nocase) {
+ startChar = Tcl_UniCharToLower(startChar);
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
- if (UCHAR(*pattern) < 0x80) {
- endChar = (Tcl_UniChar) (nocase
- ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
- pattern++;
- } else {
- pattern += Tcl_UtfToUniChar(pattern, &endChar);
- if (nocase) {
- endChar = Tcl_UniCharToLower(endChar);
- }
+ pattern += TclUtfToUniChar(pattern, &endChar);
+ if (nocase) {
+ endChar = Tcl_UniCharToLower(endChar);
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
diff --git a/tests/utf.test b/tests/utf.test
index 28981d6..f677438 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -99,17 +99,20 @@ 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}
+test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {knownBug testnumutfchars testbytestring} {
+ testnumutfchars [testbytestring "\xE2\x82\xAC"] 2
+} {2}
test utf-5.1 {Tcl_UtfFindFirsts} {
} {}
--
cgit v0.12
From c2e241f3cd55724eab1119f8bc9719d6306df7f5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 8 Jun 2017 12:34:08 +0000
Subject: Fix [2738427]: Tcl_NumUtfChars(...) no overflow check.
---
generic/tclUtf.c | 27 ++++++++++++++-------------
1 file changed, 14 insertions(+), 13 deletions(-)
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 3937141..a405367 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -464,7 +464,6 @@ Tcl_NumUtfChars(
* for strlen(string). */
{
Tcl_UniChar ch;
- register Tcl_UniChar *chPtr = &ch;
register int i;
/*
@@ -477,23 +476,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;
}
--
cgit v0.12
From 23ab25afdce1ddd24415298abf6e9a729f2a4588 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 8 Jun 2017 12:50:00 +0000
Subject: Revert part of [95d096e0378b460c6c5168bb55bb2ca8b2fd799e|95d096e037]:
Missed the fact that tolower() was optimized for the ASCII case as well, so
this was a mistake!
---
generic/tclUtil.c | 47 +++++++++++++++++++++++++++++++++++------------
1 file changed, 35 insertions(+), 12 deletions(-)
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 3fdf54b..553593c 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2162,9 +2162,14 @@ Tcl_StringCaseMatch(
* This is a special case optimization for single-byte utf.
*/
- TclUtfToUniChar(pattern, &ch2);
- if (nocase) {
- ch2 = Tcl_UniCharToLower(ch2);
+ if (UCHAR(*pattern) < 0x80) {
+ ch2 = (Tcl_UniChar)
+ (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
+ } else {
+ Tcl_UtfToUniChar(pattern, &ch2);
+ if (nocase) {
+ ch2 = Tcl_UniCharToLower(ch2);
+ }
}
while (1) {
@@ -2230,26 +2235,44 @@ Tcl_StringCaseMatch(
Tcl_UniChar startChar, endChar;
pattern++;
- str += TclUtfToUniChar(str, &ch1);
- if (nocase) {
- ch1 = Tcl_UniCharToLower(ch1);
+ if (UCHAR(*str) < 0x80) {
+ ch1 = (Tcl_UniChar)
+ (nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
+ str++;
+ } else {
+ str += Tcl_UtfToUniChar(str, &ch1);
+ if (nocase) {
+ ch1 = Tcl_UniCharToLower(ch1);
+ }
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
- pattern += TclUtfToUniChar(pattern, &startChar);
- if (nocase) {
- startChar = Tcl_UniCharToLower(startChar);
+ if (UCHAR(*pattern) < 0x80) {
+ startChar = (Tcl_UniChar) (nocase
+ ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
+ pattern++;
+ } else {
+ pattern += Tcl_UtfToUniChar(pattern, &startChar);
+ if (nocase) {
+ startChar = Tcl_UniCharToLower(startChar);
+ }
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
- pattern += TclUtfToUniChar(pattern, &endChar);
- if (nocase) {
- endChar = Tcl_UniCharToLower(endChar);
+ if (UCHAR(*pattern) < 0x80) {
+ endChar = (Tcl_UniChar) (nocase
+ ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
+ pattern++;
+ } else {
+ pattern += Tcl_UtfToUniChar(pattern, &endChar);
+ if (nocase) {
+ endChar = Tcl_UniCharToLower(endChar);
+ }
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
--
cgit v0.12