From aa9f62da23ab5e38de116429abb7fcfcc0504c4c Mon Sep 17 00:00:00 2001 From: dkf 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 e760092378d4b34b2f4cbd66a613128dbd703258 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 16:44:51 +0000 Subject: When possible delay string rep generation until necessary. --- generic/tclStringObj.c | 56 +++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index aae52ba..be71109 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2847,7 +2847,7 @@ TclStringCatObjv( Tcl_Obj * const objv[], Tcl_Obj **objPtrPtr) { - Tcl_Obj *objPtr, *objResultPtr, * const *ov; + Tcl_Obj *objPtr, *objResultPtr, * const *ov, *pendingPtr = NULL; int oc, length = 0, binary = 1, first = 0, last = 0; int allowUniChar = 1, requestUniChar = 0; @@ -2952,14 +2952,37 @@ TclStringCatObjv( objPtr = *ov++; - Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ - if (numBytes) { + if ((length == 0) && (objPtr->bytes == NULL) && !pendingPtr) { + /* No string rep; Take the chance we can avoid making it */ + last = objc - oc; - if (length == 0) { - first = last; - } - if ((length += numBytes) < 0) { - goto overflow; + first = last; + pendingPtr = objPtr; + } else { + + Tcl_GetStringFromObj(objPtr, &numBytes);/* PANIC? */ + if (numBytes) { + last = objc - oc; + if (length == 0) { + if (pendingPtr) { + int pendingNumBytes; + + Tcl_GetStringFromObj(pendingPtr, &pendingNumBytes); /* PANIC? */ + if (pendingNumBytes) { + if ((length += pendingNumBytes) < 0) { + goto overflow; + } + } else { + first = last; + } + pendingPtr = NULL; + } else { + first = last; + } + } + if ((length += numBytes) < 0) { + goto overflow; + } } } } while (--oc); @@ -3056,13 +3079,18 @@ TclStringCatObjv( } else { /* Efficiently concatenate string reps */ char *dst; + int start; if (inPlace && !Tcl_IsShared(*objv)) { - int start; - objResultPtr = *objv++; objc--; Tcl_GetStringFromObj(objResultPtr, &start); + if (pendingPtr) { + /* assert ( pendingPtr == objResultPtr ) */ + if ((length += start) < 0) { + goto overflow; + } + } if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3075,8 +3103,16 @@ TclStringCatObjv( dst = Tcl_GetString(objResultPtr) + start; if (length > start) { TclFreeIntRep(objResultPtr); + } else { + /* Can't happen ? */ } } else { + if (pendingPtr) { + Tcl_GetStringFromObj(pendingPtr, &start); + if ((length += start) < 0) { + goto overflow; + } + } objResultPtr = Tcl_NewObj(); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { -- cgit v0.12 From 5640f7a50784a038ff4a2d97550a103286352a10 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 19:35:05 +0000 Subject: Tests for string rep generation suppression --- tests/string.test | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/tests/string.test b/tests/string.test index fa7f8fb..9c43f29 100644 --- a/tests/string.test +++ b/tests/string.test @@ -1994,6 +1994,36 @@ 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"} -- cgit v0.12 From 1a49b000a0d9e7c09366f62d7ccbc904a45b6b68 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 20:31:47 +0000 Subject: pendingPtr == NULL implies (last == first) implies early out --- generic/tclStringObj.c | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index be71109..847182d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2847,7 +2847,7 @@ TclStringCatObjv( Tcl_Obj * const objv[], Tcl_Obj **objPtrPtr) { - Tcl_Obj *objPtr, *objResultPtr, * const *ov, *pendingPtr = NULL; + Tcl_Obj *objPtr, *objResultPtr, * const *ov; int oc, length = 0, binary = 1, first = 0, last = 0; int allowUniChar = 1, requestUniChar = 0; @@ -2945,6 +2945,8 @@ TclStringCatObjv( } } while (--oc); } else { + Tcl_Obj *pendingPtr = NULL; + /* Result will be concat of string reps. Pre-size it. */ ov = objv; oc = objc; do { @@ -2975,7 +2977,6 @@ TclStringCatObjv( } else { first = last; } - pendingPtr = NULL; } else { first = last; } @@ -3085,12 +3086,6 @@ TclStringCatObjv( objResultPtr = *objv++; objc--; Tcl_GetStringFromObj(objResultPtr, &start); - if (pendingPtr) { - /* assert ( pendingPtr == objResultPtr ) */ - if ((length += start) < 0) { - goto overflow; - } - } if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3107,12 +3102,6 @@ TclStringCatObjv( /* Can't happen ? */ } } else { - if (pendingPtr) { - Tcl_GetStringFromObj(pendingPtr, &start); - if ((length += start) < 0) { - goto overflow; - } - } objResultPtr = Tcl_NewObj(); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { -- cgit v0.12 From b0e8c40cebd7999b6ccf308dbf0ebb8e3be0ab0b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 20:40:45 +0000 Subject: More streamlining. --- generic/tclStringObj.c | 17 +++++------------ 1 file changed, 5 insertions(+), 12 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 847182d..c4d07e0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2967,17 +2967,9 @@ TclStringCatObjv( last = objc - oc; if (length == 0) { if (pendingPtr) { - int pendingNumBytes; - - Tcl_GetStringFromObj(pendingPtr, &pendingNumBytes); /* PANIC? */ - if (pendingNumBytes) { - if ((length += pendingNumBytes) < 0) { - goto overflow; - } - } else { - first = last; - } - } else { + Tcl_GetStringFromObj(pendingPtr, &length); /* PANIC? */ + } + if (length == 0) { first = last; } } @@ -3080,9 +3072,10 @@ TclStringCatObjv( } else { /* Efficiently concatenate string reps */ char *dst; - int start; if (inPlace && !Tcl_IsShared(*objv)) { + int start; + objResultPtr = *objv++; objc--; Tcl_GetStringFromObj(objResultPtr, &start); -- cgit v0.12 From e787f0ec1254d077093819ab5d08680448a0b217 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 20:57:06 +0000 Subject: More streamlining --- generic/tclStringObj.c | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c4d07e0..31a6b26 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2962,20 +2962,20 @@ TclStringCatObjv( pendingPtr = objPtr; } else { - Tcl_GetStringFromObj(objPtr, &numBytes);/* PANIC? */ - if (numBytes) { - last = objc - oc; - if (length == 0) { - if (pendingPtr) { - Tcl_GetStringFromObj(pendingPtr, &length); /* PANIC? */ - } - if (length == 0) { - first = last; - } - } - if ((length += numBytes) < 0) { - goto overflow; - } + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + if (numBytes == 0) { + continue; + } + last = objc - oc; + if (pendingPtr) { + Tcl_GetStringFromObj(pendingPtr, &length); /* PANIC? */ + pendingPtr = NULL; + } + if (length == 0) { + first = last; + } + if ((length += numBytes) < 0) { + goto overflow; } } } while (--oc); -- cgit v0.12 From 7c926553f6dcae359d48cc16d1ace1291a5dfb4b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 21:05:22 +0000 Subject: Modernize overflow checks. --- generic/tclStringObj.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 31a6b26..43f8016 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2916,10 +2916,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); @@ -2937,10 +2937,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); @@ -2973,10 +2973,10 @@ TclStringCatObjv( } if (length == 0) { first = last; - } - if ((length += numBytes) < 0) { + } else if (numBytes > INT_MAX - length) { goto overflow; } + length += numBytes; } } while (--oc); } -- cgit v0.12 From d6fff27296f668ac9cb89dda2fc6732634c19424 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 8 Jun 2017 21:10:01 +0000 Subject: Don't test the impossible. --- generic/tclStringObj.c | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 43f8016..aa99545 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3089,11 +3089,9 @@ TclStringCatObjv( return TCL_ERROR; } dst = Tcl_GetString(objResultPtr) + start; - if (length > start) { - TclFreeIntRep(objResultPtr); - } else { - /* Can't happen ? */ - } + + /* assert ( length > start ) */ + TclFreeIntRep(objResultPtr); } else { objResultPtr = Tcl_NewObj(); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { -- cgit v0.12