From e3074edc8ab3d499540f736d2beebe02d46200aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Feb 2022 21:01:20 +0000 Subject: TIP #618: New Tcl_GetBool* functions with INDEX_NULL_OK flag --- doc/BoolObj.3 | 13 ++++++++--- doc/GetIndex.3 | 4 ++-- generic/tcl.decls | 13 +++++++++-- generic/tcl.h | 4 ++-- generic/tclCmdMZ.c | 2 +- generic/tclDecls.h | 61 +++++++++++++++++++++++++++++++++++++++++++++++---- generic/tclExecute.c | 8 +++---- generic/tclGet.c | 23 ++++++++++++++++--- generic/tclIndexObj.c | 8 +++---- generic/tclInt.h | 4 ++-- generic/tclObj.c | 57 ++++++++++++++++++++++++++++++++++++++--------- generic/tclStubInit.c | 9 ++++++++ generic/tclTest.c | 15 +++++++------ tests/indexObj.test | 4 ++-- 14 files changed, 179 insertions(+), 46 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 9bbdc7e..afbd1d1 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj +Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj, Tcl_GetBoolFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS .nf \fB#include \fR @@ -21,6 +21,9 @@ Tcl_Obj * .sp int \fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) +.sp +int +\fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp boolValue in/out .AP int boolValue in @@ -32,9 +35,13 @@ retrieve a boolean value. If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. -.AP int *boolPtr out -Points to place where \fBTcl_GetBooleanFromObj\fR +.AP int | short | char *boolPtr out +Points to place where \fBTcl_GetBooleanFromObj\fR/\fBTcl_GetBoolFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. +.AP int flags in +Value 0 or TCL_NULL_OK. If TCL_NULL_OK, then the empty +string or NULL will result in \fBTcl_GetBoolFromObj\fR return +TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 1169c6c..176b0b2 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -54,7 +54,7 @@ Null-terminated string describing what is being looked up, such as .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR -, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR. +, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_NULL_OK\fR. .AP enum|char|short|int|long *indexPtr out If not (int *)NULL, the index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. The variable can @@ -93,7 +93,7 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed +If the \fBTCL_NULL_OK\fR flag was specified, objPtr is allowed to be NULL or the empty string. The resulting index is -1. Otherwise, if the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value diff --git a/generic/tcl.decls b/generic/tcl.decls index c137a88..4d630ca 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -136,11 +136,11 @@ declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, void *boolPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *boolPtr) + void *boolPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) @@ -2442,6 +2442,15 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +declare 668 { + int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, + void *boolPtr) +} +declare 669 { + int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags, void *boolPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index b82cf0a..560d441 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -979,13 +979,13 @@ typedef struct Tcl_DString { * TCL_EXACT disallows abbreviated strings. * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. - * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK. + * TCL_NULL_OK allows the empty string or NULL to return TCL_OK. * The returned value will be -1; */ #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 -#define TCL_INDEX_NULL_OK 4 +#define TCL_NULL_OK 32 /* *---------------------------------------------------------------------------- diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f394035..6b991eb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1620,7 +1620,7 @@ StringIsCmd( result = length1 == 0; } } else if (index != STR_IS_BOOL) { - TclGetBooleanFromObj(NULL, objPtr, &i); + TclGetBoolFromObj(NULL, objPtr, 0, &i); if ((index == STR_IS_TRUE) ^ i) { result = 0; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b5697ea..da28cb7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -146,10 +146,10 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - int *boolPtr); + void *boolPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *boolPtr); + Tcl_Obj *objPtr, void *boolPtr); /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr); @@ -1948,6 +1948,19 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* 668 */ +EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, + int flags, void *boolPtr); +/* 669 */ +EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int flags, void *boolPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2006,8 +2019,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ + int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, void *boolPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ @@ -2644,6 +2657,15 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + void (*reserved661)(void); + void (*reserved662)(void); + void (*reserved663)(void); + void (*reserved664)(void); + void (*reserved665)(void); + void (*reserved666)(void); + void (*reserved667)(void); + int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, void *boolPtr); /* 668 */ + int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, void *boolPtr); /* 669 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3994,6 +4016,17 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +#define Tcl_GetBool \ + (tclStubsPtr->tcl_GetBool) /* 668 */ +#define Tcl_GetBoolFromObj \ + (tclStubsPtr->tcl_GetBoolFromObj) /* 669 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4210,6 +4243,10 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct +#undef Tcl_GetBoolFromObj +#undef Tcl_GetBool +#undef Tcl_GetBooleanFromObj +#undef Tcl_GetBoolean #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj @@ -4220,6 +4257,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) +#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ + (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ + (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)boolPtr) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)boolPtr) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) @@ -4233,6 +4278,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) +#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ + ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ + ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)boolPtr) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? (Tcl_GetBoolean)(interp, src, (int *)boolPtr) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index dfb195a..2c4cde4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4346,7 +4346,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { + if (TclGetBoolFromObj(interp, valuePtr, 0, &b) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4414,7 +4414,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { + if (TclGetBoolFromObj(NULL, valuePtr, 0, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -4423,7 +4423,7 @@ TEBCresume( goto gotError; } - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { + if (TclGetBoolFromObj(NULL, value2Ptr, 0, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -6222,7 +6222,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { + if (TclGetBoolFromObj(NULL, valuePtr, 0, &b) != TCL_OK) { TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); diff --git a/generic/tclGet.c b/generic/tclGet.c index 970e093..1beac24 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -121,17 +121,22 @@ Tcl_GetDouble( *---------------------------------------------------------------------- */ +#undef Tcl_GetBool int -Tcl_GetBoolean( +Tcl_GetBool( Tcl_Interp *interp, /* Interpreter used for error reporting. */ const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ - int *boolPtr) /* Place to store converted result, which will + int flags, + void *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; int code; + if (((src == NULL) || (*src == '\0')) && (flags & TCL_NULL_OK)) { + return (Tcl_GetBoolFromObj)(NULL, NULL, flags, boolPtr); + } obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); @@ -142,10 +147,22 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - TclGetBooleanFromObj(NULL, &obj, boolPtr); + (Tcl_GetBoolFromObj)(NULL, &obj, flags, boolPtr); } return code; } + +#undef Tcl_GetBoolean +int +Tcl_GetBoolean( + Tcl_Interp *interp, /* Interpreter used for error reporting. */ + const char *src, /* String containing one of the boolean values + * 1, 0, true, false, yes, no, on, off. */ + void *boolPtr) /* Place to store converted result, which will + * be 0 or 1. */ +{ + return Tcl_GetBool(interp, src, 0, boolPtr); +} /* * Local Variables: diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 1f600c5..f5e3958 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -263,7 +263,7 @@ Tcl_GetIndexFromObjStruct( int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */ + int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_NULL_OK */ void *indexPtr) /* Place to store resulting index. */ { int index, idx, numAbbrev; @@ -304,7 +304,7 @@ Tcl_GetIndexFromObjStruct( index = -1; numAbbrev = 0; - if (!*key && (flags & TCL_INDEX_NULL_OK)) { + if (!*key && (flags & TCL_NULL_OK)) { goto uncachedDone; } /* @@ -411,7 +411,7 @@ Tcl_GetIndexFromObjStruct( *entryPtr, NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { - if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) { + if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); } else if (**entryPtr) { @@ -420,7 +420,7 @@ Tcl_GetIndexFromObjStruct( } entryPtr = NEXT_ENTRY(entryPtr, offset); } - if ((flags & TCL_INDEX_NULL_OK)) { + if ((flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index 75cd6e5..25593b2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2504,12 +2504,12 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ +#define TclGetBoolFromObj(interp, objPtr, flags, boolPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + : Tcl_GetBoolFromObj((interp), (objPtr), (flags), (boolPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index a06b8fd..636f8e0 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2139,7 +2139,7 @@ Tcl_SetBooleanObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBooleanFromObj -- + * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This * includes conversion from any of Tcl's numeric types. @@ -2155,20 +2155,28 @@ Tcl_SetBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetBoolFromObj int -Tcl_GetBooleanFromObj( +Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int *boolPtr) /* Place to store resulting boolean. */ + int flags, + void *boolPtr) /* Place to store resulting boolean. */ { + int result; + + if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { + result = -1; + goto boolEnd; + } do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; + result = (objPtr->internalRep.wideValue != 0); + goto boolEnd; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = objPtr->internalRep.longValue != 0; - return TCL_OK; + result = objPtr->internalRep.longValue != 0; + goto boolEnd; } if (objPtr->typePtr == &tclDoubleType) { /* @@ -2184,11 +2192,30 @@ Tcl_GetBooleanFromObj( if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } - *boolPtr = (d != 0.0); - return TCL_OK; + result = (d != 0.0); + goto boolEnd; } if (objPtr->typePtr == &tclBignumType) { - *boolPtr = 1; + result = 1; + boolEnd: + if (boolPtr != NULL) { + if ((flags>>8) & (int)~sizeof(int)) { + if ((flags>>8) == sizeof(uint64_t)) { + *(uint64_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint32_t)) { + *(uint32_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint16_t)) { + *(uint16_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint8_t)) { + *(uint8_t *)boolPtr = result; + return TCL_OK; + } + } + *(int *)boolPtr = result; + } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == @@ -2196,6 +2223,16 @@ Tcl_GetBooleanFromObj( return TCL_ERROR; } +#undef Tcl_GetBooleanFromObj +int +Tcl_GetBooleanFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + void *boolPtr) /* Place to store resulting boolean. */ +{ + return Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr); +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a1878c1..ff2b296 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1944,6 +1944,15 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + 0, /* 661 */ + 0, /* 662 */ + 0, /* 663 */ + 0, /* 664 */ + 0, /* 665 */ + 0, /* 666 */ + 0, /* 667 */ + Tcl_GetBool, /* 668 */ + Tcl_GetBoolFromObj, /* 669 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..97fd57f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2174,7 +2174,7 @@ TesteventProc( Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); - int retval; + char retval[3]; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, @@ -2183,18 +2183,18 @@ TesteventProc( return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), - &retval) != TCL_OK) { + &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); return 1; } - if (retval) { + if (retval[1]) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); } - return retval; + return retval[1]; } /* @@ -5188,7 +5188,8 @@ TestsaveresultCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { Interp* iPtr = (Interp*) interp; - int discard, result, index; + int result, index; + short discard[3]; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5210,7 +5211,7 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard[1]) != TCL_OK) { return TCL_ERROR; } @@ -5247,7 +5248,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (discard) { + if (discard[1]) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); diff --git a/tests/indexObj.test b/tests/indexObj.test index c327274..f10bd2a 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -142,8 +142,8 @@ test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testi } -returnCodes error -result {ambiguous dummy "": must be a, c, or ee} test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj { set x "" - testgetindexfromobjstruct $x -1 4 -} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\"" + testgetindexfromobjstruct $x -1 32 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12 From c9e33a6348a3521e24d190c2d8a653a70e62f0ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:24:31 +0000 Subject: uint??_t -> int??_t --- generic/tclObj.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 636f8e0..11a8530 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2200,17 +2200,17 @@ Tcl_GetBoolFromObj( boolEnd: if (boolPtr != NULL) { if ((flags>>8) & (int)~sizeof(int)) { - if ((flags>>8) == sizeof(uint64_t)) { - *(uint64_t *)boolPtr = result; + if ((flags>>8) == sizeof(int64_t)) { + *(int64_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint32_t)) { - *(uint32_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int32_t)) { + *(int32_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint16_t)) { - *(uint16_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int16_t)) { + *(int16_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint8_t)) { - *(uint8_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int8_t)) { + *(int8_t *)boolPtr = result; return TCL_OK; } } -- cgit v0.12 From d78db33c23ca9fad833989314d1288dafbfd039e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:37:09 +0000 Subject: Handle objPtr == NULL / interp == NULL better --- generic/tclObj.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclObj.c b/generic/tclObj.c index 11a8530..ae20e16 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2168,6 +2168,13 @@ Tcl_GetBoolFromObj( if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { result = -1; goto boolEnd; + } else if (objPtr == NULL) { + if (interp) { + TclNewObj(objPtr); + TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0); + Tcl_DecrRefCount(objPtr); + } + return TCL_ERROR; } do { if (objPtr->typePtr == &tclIntType) { -- cgit v0.12 From 9ad31cfcf31c75506cd932dfb2d637d4ff299131 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:48:51 +0000 Subject: Better errpr-handling --- generic/tclGet.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclGet.c b/generic/tclGet.c index 1beac24..27f3235 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -134,8 +134,8 @@ Tcl_GetBool( Tcl_Obj obj; int code; - if (((src == NULL) || (*src == '\0')) && (flags & TCL_NULL_OK)) { - return (Tcl_GetBoolFromObj)(NULL, NULL, flags, boolPtr); + if ((src == NULL) || (*src == '\0')) { + return (Tcl_GetBoolFromObj)(interp, NULL, flags, boolPtr); } obj.refCount = 1; obj.bytes = (char *) src; -- cgit v0.12 From bcedb2cdf604551b21205b0319c6876a108893e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 3 Apr 2022 12:11:25 +0000 Subject: Add Ashok's example --- generic/tclTest.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 72a055e..8d2272c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -30,6 +30,7 @@ #endif #include "tclOO.h" #include +#include /* * Required for Testregexp*Cmd @@ -5277,7 +5278,7 @@ TestsaveresultCmd( { Interp* iPtr = (Interp*) interp; int result, index; - short discard[3]; + bool b[3]; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5299,7 +5300,7 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[3], &discard[1]) != TCL_OK) { + if (Tcl_GetBoolFromObj(interp, objv[3], 0, b+1) != TCL_OK) { return TCL_ERROR; } @@ -5336,7 +5337,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (discard[1]) { + if (b[1]) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); -- cgit v0.12 From 9b8a5d56d248638f34ad54292129773ed663c63a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Apr 2022 01:42:45 +0000 Subject: Panic if Testsaveresult call to Tcl_GetBoolFromObj overwrites memory. --- generic/tclTest.c | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8d2272c..51d3764 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5300,11 +5300,17 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBoolFromObj(interp, objv[3], 0, b+1) != TCL_OK) { - return TCL_ERROR; - } + b[0] = b[1] = b[2] = 100; + if (Tcl_GetBoolFromObj(interp, objv[3], 0, b + 1) != TCL_OK) + { + return TCL_ERROR; + } + if (b[0] != 100 || b[2] != 100) { + Tcl_Panic("MEMORY OVERWRITE IN Tcl_GetBoolFromObj"); + return TCL_ERROR; + } - freeCount = 0; + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: -- cgit v0.12 From 706ec57375c74eee06320a7b6c722e464a10a9ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 11:50:49 +0000 Subject: Use lower 5 bits of flags for sizeof(*(boolPtr)) --- generic/tclDecls.h | 8 ++++---- generic/tclObj.c | 16 +++++++--------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4b8c09a..3cfbc42 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4285,9 +4285,9 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) #define Tcl_GetBoolean(interp, src, boolPtr) \ @@ -4306,9 +4306,9 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) #define Tcl_GetBoolean(interp, src, boolPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index ae20e16..439e854 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2206,22 +2206,20 @@ Tcl_GetBoolFromObj( result = 1; boolEnd: if (boolPtr != NULL) { - if ((flags>>8) & (int)~sizeof(int)) { - if ((flags>>8) == sizeof(int64_t)) { + flags &= (TCL_NULL_OK - 1); + if (flags & (int)~sizeof(int8_t)) { + if (flags == sizeof(int64_t)) { *(int64_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int32_t)) { + } else if (flags == sizeof(int32_t)) { *(int32_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int16_t)) { + } else if (flags == sizeof(int16_t)) { *(int16_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int8_t)) { - *(int8_t *)boolPtr = result; - return TCL_OK; - } + } } - *(int *)boolPtr = result; + *(int8_t *)boolPtr = result; } return TCL_OK; } -- cgit v0.12 From 42cd1c73d2440e5f4c6c5015bc740f13d0b8decd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 12:20:31 +0000 Subject: Restore Tcl_GetBoolenanFromObj/Tcl_GetBoolenan signatures --- generic/tcl.decls | 4 ++-- generic/tclDecls.h | 16 ++++------------ generic/tclGet.c | 4 ++-- generic/tclObj.c | 4 ++-- generic/tclTest.c | 4 ++-- 5 files changed, 12 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 883312e..a450130 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -136,11 +136,11 @@ declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, void *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - void *boolPtr) + int *boolPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3cfbc42..ebaa279 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -146,10 +146,10 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - void *boolPtr); + int *boolPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, void *boolPtr); + Tcl_Obj *objPtr, int *boolPtr); /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr); @@ -2032,8 +2032,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, void *boolPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *boolPtr); /* 32 */ + int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ @@ -4288,10 +4288,6 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) @@ -4309,10 +4305,6 @@ extern const TclStubs *tclStubsPtr; ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBoolean)(interp, src, (int *)(boolPtr)) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) diff --git a/generic/tclGet.c b/generic/tclGet.c index 27f3235..9a1b3c0 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -158,10 +158,10 @@ Tcl_GetBoolean( Tcl_Interp *interp, /* Interpreter used for error reporting. */ const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ - void *boolPtr) /* Place to store converted result, which will + int *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { - return Tcl_GetBool(interp, src, 0, boolPtr); + return Tcl_GetBool(interp, src, sizeof(int), boolPtr); } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 439e854..89b576c 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2233,9 +2233,9 @@ int Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ - void *boolPtr) /* Place to store resulting boolean. */ + int *boolPtr) /* Place to store resulting boolean. */ { - return Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr); + return Tcl_GetBoolFromObj(interp, objPtr, sizeof(int), boolPtr); } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 646987b..db25379 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2270,8 +2270,8 @@ TesteventProc( Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } - if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), - &retval[1]) != TCL_OK) { + if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), + 0, &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); -- cgit v0.12 From 757c9098818f6fa4cb48fa8e522e767d6c0dde4d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 12:27:39 +0000 Subject: Remove macro's for Tcl_GetBoolFromObj/Tcl_GetBool --- generic/tclDecls.h | 12 ------------ generic/tclTest.c | 4 ++-- 2 files changed, 2 insertions(+), 14 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ebaa279..790af99 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4270,10 +4270,6 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct -#undef Tcl_GetBoolFromObj -#undef Tcl_GetBool -#undef Tcl_GetBooleanFromObj -#undef Tcl_GetBoolean #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj @@ -4284,10 +4280,6 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) -#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) @@ -4301,10 +4293,6 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) -#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) diff --git a/generic/tclTest.c b/generic/tclTest.c index db25379..4cd9bab 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2271,7 +2271,7 @@ TesteventProc( return 1; /* Avoid looping on errors */ } if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), - 0, &retval[1]) != TCL_OK) { + sizeof(retval[1]), &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); @@ -5300,7 +5300,7 @@ TestsaveresultCmd( return TCL_ERROR; } b[0] = b[1] = b[2] = 100; - if (Tcl_GetBoolFromObj(interp, objv[3], 0, b + 1) != TCL_OK) + if (Tcl_GetBoolFromObj(interp, objv[3], sizeof(b[1]), b + 1) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From ad9c975e41ced7cdc2f156f683fa8845fb33735a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 14:46:00 +0000 Subject: Update documentation --- doc/BoolObj.3 | 18 +++++++++++++----- doc/GetInt.3 | 21 ++++++++++++++++----- 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index afbd1d1..c5bb05f 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -20,7 +20,7 @@ Tcl_Obj * \fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR) .sp int -\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) +\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. boolPtr\fR) @@ -35,13 +35,16 @@ retrieve a boolean value. If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. +.AP int *intPtr out +Points to place where \fBTcl_GetBooleanFromObj\fR +stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .AP int | short | char *boolPtr out -Points to place where \fBTcl_GetBooleanFromObj\fR/\fBTcl_GetBoolFromObj\fR +Points to place where \fBTcl_GetBoolFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .AP int flags in -Value 0 or TCL_NULL_OK. If TCL_NULL_OK, then the empty -string or NULL will result in \fBTcl_GetBoolFromObj\fR return -TCL_OK, the *boolPtr filled with the value -1; +sizeof(*(boolPtr)), possibly combined with TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBoolFromObj\fR +return TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION @@ -83,6 +86,11 @@ fields of \fI*objPtr\fR so that future calls to \fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be performed more efficiently. .PP +\fBTcl_GetBoolFromObj\fR functions almost the same as +\fBTcl_GetBooleanFromObj\fR, but it has an additional parameter +\fBflags\fR, which can be used to specify the size of the \fBboolPtr\fR +variable, and also whether the empty string or NULL is accepted as valid. +.PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. The set of values for which \fBTcl_GetBooleanFromObj\fR diff --git a/doc/GetInt.3 b/doc/GetInt.3 index f9b91a2..edce6c1 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -21,7 +21,10 @@ int \fBTcl_GetDouble\fR(\fIinterp, src, doublePtr\fR) .sp int -\fBTcl_GetBoolean\fR(\fIinterp, src, boolPtr\fR) +\fBTcl_GetBoolean\fR(\fIinterp, src, intPtr\fR) +.sp +int +\fBTcl_GetBool\fR(\fIinterp, src, flags, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in @@ -34,7 +37,11 @@ Points to place to store integer value converted from \fIsrc\fR. Points to place to store double-precision floating-point value converted from \fIsrc\fR. .AP int | short | char *boolPtr out -Points to place to store boolean value (0 or 1) converted from \fIsrc\fR. +Points to place to store boolean value (0 or 1) value converted from \fIsrc\fR. +.AP int flags in +sizeof(*(boolPtr)), possibly combined with TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBool\fR +return TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION @@ -94,11 +101,15 @@ inter-digit separator be present. \fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero -value at \fI*boolPtr\fR. +value at \fI*intPtr\fR. If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, -then 1 is stored at \fI*boolPtr\fR. +then 1 is stored at \fI*intPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. - +.PP +\fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR, +but it has an additional parameter \fBflags\fR, which can be used +to specify the size of the \fBboolPtr\fR variable, and also whether +the empty string or NULL is accepted as valid. .SH KEYWORDS boolean, conversion, double, floating-point, integer -- cgit v0.12 From 43ea8e68e8f54392631b95557d6dc9c621afc667 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Apr 2022 14:26:06 +0000 Subject: Simplify TclGetBoolFromObj() macro --- generic/tclCmdMZ.c | 2 +- generic/tclExecute.c | 8 ++++---- generic/tclInt.h | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3eaf055..f394035 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1620,7 +1620,7 @@ StringIsCmd( result = length1 == 0; } } else if (index != STR_IS_BOOL) { - TclGetBoolFromObj(NULL, objPtr, sizeof(i), &i); + TclGetBooleanFromObj(NULL, objPtr, &i); if ((index == STR_IS_TRUE) ^ i) { result = 0; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e16da5..0ec2404 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4346,7 +4346,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBoolFromObj(interp, valuePtr, sizeof(b), &b) != TCL_OK) { + if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4414,7 +4414,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (TclGetBoolFromObj(NULL, valuePtr, sizeof(i1), &i1) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -4423,7 +4423,7 @@ TEBCresume( goto gotError; } - if (TclGetBoolFromObj(NULL, value2Ptr, sizeof(i2), &i2) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -6223,7 +6223,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBoolFromObj(NULL, valuePtr, sizeof(b), &b) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); diff --git a/generic/tclInt.h b/generic/tclInt.h index e3ebe57..c39a9f6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2507,12 +2507,12 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#define TclGetBoolFromObj(interp, objPtr, flags, boolPtr) \ +#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBoolFromObj((interp), (objPtr), (flags), (boolPtr))) + ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : (Tcl_GetBoolFromObj)((interp), (objPtr), (int)sizeof(int), (intPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ -- cgit v0.12 From d3662a9dca03f16538eae7240e56fb57589bd9e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 29 Apr 2022 20:09:48 +0000 Subject: re-structure, add more examples --- generic/tcl.decls | 4 ++-- generic/tclCompCmdsGR.c | 3 ++- generic/tclCompCmdsSZ.c | 4 +++- generic/tclCompExpr.c | 3 ++- generic/tclDecls.h | 26 ++++++++++++++++++++++---- generic/tclGet.c | 9 +++++++-- generic/tclInt.h | 2 +- generic/tclObj.c | 30 ++++++++++++------------------ generic/tclTest.c | 29 ++++++++++++----------------- 9 files changed, 63 insertions(+), 47 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 3d59139..2c19545 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2457,11 +2457,11 @@ declare 668 { declare 674 { int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, - void *boolPtr) + char *boolPtr) } declare 675 { int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags, void *boolPtr) + int flags, char *boolPtr) } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index da557a4..839fbde 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" #include +#include /* * Prototypes for procedures defined later in this file: @@ -185,7 +186,7 @@ TclCompileIfCmd( const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ + bool boolVal; /* Value of static condition. */ int compileScripts = 1; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cd3bd37..fa490a1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -18,6 +18,7 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclStringTrim.h" +#include /* * Prototypes for procedures defined later in this file: @@ -3759,7 +3760,8 @@ TclCompileWhileCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + int testCodeOffset, bodyCodeOffset, jumpDist, range, code; + bool boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 23d8711..c245b4e 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ +#include /* * Expression parsing takes place in the routine ParseExpr(). It takes a @@ -708,7 +709,7 @@ ParseExpr( */ if ((NODE_TYPE & lexeme) == 0) { - int b; + bool b; switch (lexeme) { case COMMENT: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d75e605..04f8aa3 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1970,10 +1970,10 @@ EXTERN int Tcl_UniCharLen(const int *uniStr); /* Slot 673 is reserved */ /* 674 */ EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, - int flags, void *boolPtr); + int flags, char *boolPtr); /* 675 */ EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int flags, void *boolPtr); + Tcl_Obj *objPtr, int flags, char *boolPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2683,8 +2683,8 @@ typedef struct TclStubs { void (*reserved671)(void); void (*reserved672)(void); void (*reserved673)(void); - int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, void *boolPtr); /* 674 */ - int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, void *boolPtr); /* 675 */ + int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *boolPtr); /* 674 */ + int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *boolPtr); /* 675 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4270,12 +4270,22 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct +#undef Tcl_GetBoolean +#undef Tcl_GetBooleanFromObj #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #endif #if defined(USE_TCL_STUBS) +#define Tcl_GetBoolean(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? tclStubsPtr->tcl_GetBool(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? tclStubsPtr->tcl_GetBoolFromObj(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ @@ -4289,6 +4299,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #endif #else +#define Tcl_GetBoolean(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBoolean)(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? (Tcl_GetBool)(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? (Tcl_GetBoolFromObj)(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ diff --git a/generic/tclGet.c b/generic/tclGet.c index 0e07da1..a60d3a6 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -128,7 +128,7 @@ Tcl_GetBool( const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ int flags, - void *boolPtr) /* Place to store converted result, which will + char *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; @@ -161,7 +161,12 @@ Tcl_GetBoolean( int *intPtr) /* Place to store converted result, which will * be 0 or 1. */ { - return Tcl_GetBool(interp, src, sizeof(int), intPtr); + char boolValue; + int result = Tcl_GetBool(interp, src, 0, &boolValue); + if (intPtr) { + *intPtr = boolValue; + } + return result; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ee22f3..61cc3b3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2512,7 +2512,7 @@ typedef struct List { ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBoolFromObj((interp), (objPtr), (int)sizeof(int), (intPtr))) + : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index 40fc73b..7842d0d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2161,7 +2161,7 @@ Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ int flags, - void *boolPtr) /* Place to store resulting boolean. */ + char *boolPtr) /* Place to store resulting boolean. */ { int result; @@ -2171,7 +2171,8 @@ Tcl_GetBoolFromObj( } else if (objPtr == NULL) { if (interp) { TclNewObj(objPtr); - TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL, -1, NULL, 0); Tcl_DecrRefCount(objPtr); } return TCL_ERROR; @@ -2206,25 +2207,13 @@ Tcl_GetBoolFromObj( result = 1; boolEnd: if (boolPtr != NULL) { - flags &= (TCL_NULL_OK - 1); - if (flags & (int)~sizeof(int8_t)) { - if (flags == sizeof(int16_t)) { - *(int16_t *)boolPtr = result; - return TCL_OK; - } else if (flags == sizeof(int32_t)) { - *(int32_t *)boolPtr = result; - return TCL_OK; - } else if (flags == sizeof(int64_t)) { - *(int64_t *)boolPtr = result; - return TCL_OK; - } - } - *(int8_t *)boolPtr = result; + *boolPtr = result; } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == - TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } @@ -2235,7 +2224,12 @@ Tcl_GetBooleanFromObj( Tcl_Obj *objPtr, /* The object from which to get boolean. */ int *intPtr) /* Place to store resulting boolean. */ { - return Tcl_GetBoolFromObj(interp, objPtr, sizeof(int), intPtr); + char boolValue; + int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &boolValue); + if (intPtr) { + *intPtr = boolValue; + } + return result; } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 4cd9bab..39364d6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -30,6 +30,7 @@ #endif #include "tclOO.h" #include +#include /* * Required for Testregexp*Cmd @@ -2262,7 +2263,7 @@ TesteventProc( Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); - char retval[3]; + bool retval; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, @@ -2270,19 +2271,19 @@ TesteventProc( Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } - if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), - sizeof(retval[1]), &retval[1]) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), + &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); return 1; } - if (retval[1]) { + if (retval) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); } - return retval[1]; + return retval; } /* @@ -5277,7 +5278,7 @@ TestsaveresultCmd( { Interp* iPtr = (Interp*) interp; int result, index; - char b[3]; + bool discard; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5299,17 +5300,11 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - b[0] = b[1] = b[2] = 100; - if (Tcl_GetBoolFromObj(interp, objv[3], sizeof(b[1]), b + 1) != TCL_OK) - { - return TCL_ERROR; - } - if (b[0] != 100 || b[2] != 100) { - Tcl_Panic("MEMORY OVERWRITE IN Tcl_GetBoolFromObj"); - return TCL_ERROR; - } + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { + return TCL_ERROR; + } - freeCount = 0; + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: @@ -5342,7 +5337,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (b[1]) { + if (discard) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); -- cgit v0.12 From a83edfe07c35a66fbcf357a99349c43e103e6d9e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 May 2022 10:18:44 +0000 Subject: Update doc --- doc/BoolObj.3 | 4 ++-- doc/GetInt.3 | 3 +-- generic/tclGet.c | 6 +++--- generic/tclObj.c | 30 +++++++++++++++--------------- 4 files changed, 21 insertions(+), 22 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index cc8729e..47a2189 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -88,8 +88,8 @@ performed more efficiently. .PP \fBTcl_GetBoolFromObj\fR functions almost the same as \fBTcl_GetBooleanFromObj\fR, but it has an additional parameter -\fBflags\fR, which can be used to specify the size of the \fBbool\fR -variable, and also whether the empty string or NULL is accepted as valid. +\fBflags\fR, which can be used to specify whether the empty +string or NULL is accepted as valid. .PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. diff --git a/doc/GetInt.3 b/doc/GetInt.3 index 62e8f51..f15c12d 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -109,8 +109,7 @@ are also acceptable. .PP \fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR, but it has an additional parameter \fBflags\fR, which can be used -to specify the size of the \fBbool\fR variable, and also whether -the empty string or NULL is accepted as valid. +to specify whether the empty string or NULL is accepted as valid. .SH KEYWORDS boolean, conversion, double, floating-point, integer diff --git a/generic/tclGet.c b/generic/tclGet.c index 9670450..3c458dc 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -161,10 +161,10 @@ Tcl_GetBoolean( int *intPtr) /* Place to store converted result, which will * be 0 or 1. */ { - char boolValue; - int result = Tcl_GetBool(interp, src, 0, &boolValue); + char charValue; + int result = Tcl_GetBool(interp, src, 0, &charValue); if (intPtr) { - *intPtr = boolValue; + *intPtr = charValue; } return result; } diff --git a/generic/tclObj.c b/generic/tclObj.c index f7d9dfc..ce13638 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2004,7 +2004,7 @@ Tcl_FreeInternalRep( * * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "boolValue" + * initializes it from the argument boolean value. A nonzero "intValue" * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result @@ -2025,20 +2025,20 @@ Tcl_FreeInternalRep( Tcl_Obj * Tcl_NewBooleanObj( - int boolValue) /* Boolean used to initialize new object. */ + int intValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0); + return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewBooleanObj( - int boolValue) /* Boolean used to initialize new object. */ + int intValue) /* Boolean used to initialize new object. */ { Tcl_Obj *objPtr; - TclNewIntObj(objPtr, boolValue!=0); + TclNewIntObj(objPtr, intValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -2075,7 +2075,7 @@ Tcl_NewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - int boolValue, /* Boolean used to initialize new object. */ + int intValue, /* Boolean used to initialize new object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -2087,7 +2087,7 @@ Tcl_DbNewBooleanObj( /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.wideValue = (boolValue != 0); + objPtr->internalRep.wideValue = (intValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -2096,11 +2096,11 @@ Tcl_DbNewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - int boolValue, /* Boolean used to initialize new object. */ + int intValue, /* Boolean used to initialize new object. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewBooleanObj(boolValue); + return Tcl_NewBooleanObj(intValue); } #endif /* TCL_MEM_DEBUG */ @@ -2110,7 +2110,7 @@ Tcl_DbNewBooleanObj( * Tcl_SetBooleanObj -- * * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "boolValue" is coerced to 1. + * boolean value. A nonzero "intValue" is coerced to 1. * * Results: * None. @@ -2126,13 +2126,13 @@ Tcl_DbNewBooleanObj( void Tcl_SetBooleanObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int boolValue) /* Boolean used to set object's value. */ + int intValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetIntObj(objPtr, boolValue!=0); + TclSetIntObj(objPtr, intValue!=0); } #endif /* TCL_NO_DEPRECATED */ @@ -2224,10 +2224,10 @@ Tcl_GetBooleanFromObj( Tcl_Obj *objPtr, /* The object from which to get boolean. */ int *intPtr) /* Place to store resulting boolean. */ { - char boolValue; - int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &boolValue); + char charValue; + int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &charValue); if (intPtr) { - *intPtr = boolValue; + *intPtr = charValue; } return result; } -- cgit v0.12 From dc113d8f285f5b53a9fa035527abe05704027ab4 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 18 Aug 2022 20:16:05 +0000 Subject: TIP633 fconfigure -tolerantencoding: start command arguments --- generic/tclIO.c | 27 ++++++++++++++++++++++++++- generic/tclIO.h | 2 ++ 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5313eed..4e3e41c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7905,7 +7905,20 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-translation")) { + if (len == 0 || HaveOpt(2, "-tolerantencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_TOLERANT_ENCODING) ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + if (len > 0) { + return TCL_OK; + } + } + if (len == 0 || HaveOpt(2, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); } @@ -8158,6 +8171,18 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; + } else if (HaveOpt(2, "-tolerantencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags |= CHANNEL_TOLERANT_ENCODING; + } else { + statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; diff --git a/generic/tclIO.h b/generic/tclIO.h index 54aa5af..1d63c0b 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,6 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_TOLERANT_ENCODING (1<<17) /* set if option -tolerantencoding + * is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and -- cgit v0.12 From 9a1e8d3202a29dcc11dc8c54e01a02e1f6565fd1 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 18 Aug 2022 20:20:10 +0000 Subject: Correct option shortcut value --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e3e41c..6d9798e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8183,7 +8183,7 @@ Tcl_SetChannelOption( statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; } return TCL_OK; - } else if (HaveOpt(1, "-translation")) { + } else if (HaveOpt(2, "-translation")) { const char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { -- cgit v0.12 From 688186d7268b10d38b7e93cfa719208ebc1f96b2 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 25 Aug 2022 20:07:29 +0000 Subject: TIP633 fconfigure -tolerantencoding: set tolerant 8.7 default value. --- generic/tclIO.c | 14 +++++++++++--- generic/tclIO.h | 2 +- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6d9798e..cf96559 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1703,6 +1703,14 @@ Tcl_CreateChannel( statePtr->outputEncodingFlags = TCL_ENCODING_START; /* + * Set encoding tolerant mode as default on 8.7.x and off on TCL9.x + */ + + #if TCL_MAJOR_VERSION < 9 + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + #endif + + /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and @@ -7910,7 +7918,7 @@ Tcl_GetChannelOption( Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); } Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_TOLERANT_ENCODING) ? "1" : "0"); + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); if (len > 0) { return TCL_OK; } @@ -8178,9 +8186,9 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - statePtr->flags |= CHANNEL_TOLERANT_ENCODING; + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; } else { - statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; + statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; } return TCL_OK; } else if (HaveOpt(2, "-translation")) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 1d63c0b..58e0c0f 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,7 +271,7 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_TOLERANT_ENCODING (1<<17) /* set if option -tolerantencoding +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -tolerantencoding * is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. -- cgit v0.12 From 8ad68e4ae6be99da8761d19c3755707dd0f08f95 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 9 Sep 2022 17:09:10 +0000 Subject: TIP633: fconfigure -tolerantencoding: correct/add command interface tests --- tests/io.test | 15 +++++++++++++++ tests/ioCmd.test | 12 ++++++------ tests/socket.test | 2 +- tests/zlib.test | 4 ++-- 4 files changed, 24 insertions(+), 9 deletions(-) diff --git a/tests/io.test b/tests/io.test index b6c4fb5..653c02b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8985,6 +8985,21 @@ test io-75.2 {unrepresentable character write passes and is replaced by ?} -setu removeFile io-75.2 } -returnCodes ok -result "A?" +test io-75.3 {check if -tolerantencoding option is saved} -setup { + set fn [makeFile {} io-75.3] + set f [open $fn w] +} -body { + # the following command gets in result error in TCL 9.0 + fconfigure $f -encoding iso8859-1 -tolerantencoding 0 + lappend res [fconfigure $f -tolerantencoding] + fconfigure $f -encoding iso8859-1 -tolerantencoding 1 + lappend res [fconfigure $f -tolerantencoding] +} -cleanup { + close $f + removeFile io-75.3 +} -returnCodes ok -result "0 1" + + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..908ac5a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..c354f46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 16 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" diff --git a/tests/zlib.test b/tests/zlib.test index 7de6d64..8c2d368 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 370f7dfa406329d5dfbf91ef4da3d647230ee99c Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 08:55:59 +0000 Subject: TIP633 fconfigure -strictencoding: change option name to "-strictencoding". --- generic/tclIO.c | 12 ++++++------ generic/tclIO.h | 4 ++-- tests/io.test | 14 -------------- tests/ioCmd.test | 12 ++++++------ tests/zlib.test | 4 ++-- 5 files changed, 16 insertions(+), 30 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index cf96559..0f5f9c0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7913,12 +7913,12 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-tolerantencoding")) { + if (len == 0 || HaveOpt(2, "-strictencoding")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); } Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); if (len > 0) { return TCL_OK; } @@ -8179,16 +8179,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(2, "-tolerantencoding")) { + } else if (HaveOpt(2, "-strictencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } if (newMode) { - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; - } else { statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; + } else { + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; } return TCL_OK; } else if (HaveOpt(2, "-translation")) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 58e0c0f..54ffe0e 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,8 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -tolerantencoding - * is set to 1 */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding + * is set to 0 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/io.test b/tests/io.test index adb5620..5c45918 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9006,20 +9006,6 @@ test io-75.3 {incomplete multibyte encoding read is ignored} -setup { removeFile io-75.3 } -returnCodes ok -result "A\xC0" -test io-75.4 {check if -tolerantencoding option is saved} -setup { - set fn [makeFile {} io-75.4] - set f [open $fn w] -} -body { - # the following command gets in result error in TCL 9.0 - fconfigure $f -encoding iso8859-1 -tolerantencoding 0 - lappend res [fconfigure $f -tolerantencoding] - fconfigure $f -encoding iso8859-1 -tolerantencoding 1 - lappend res [fconfigure $f -tolerantencoding] -} -cleanup { - close $f - removeFile io-75.4 -} -returnCodes ok -result "0 1" - # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 908ac5a..178b54a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index 8c2d368..f848b58 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 330bdbdecea1f151f8d1f1bdb7648ce6161b795e Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 09:27:10 +0000 Subject: TIP633 fconfigure -strictencoding: make only "-strictencoding 0" possible on TCL 8.7 --- generic/tclIO.c | 31 +++++++++++-------------------- generic/tclIO.h | 2 -- tests/ioCmd.test | 19 +++++++++++++------ tests/zlib.test | 4 ++-- 4 files changed, 26 insertions(+), 30 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0f5f9c0..b801441 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1703,14 +1703,6 @@ Tcl_CreateChannel( statePtr->outputEncodingFlags = TCL_ENCODING_START; /* - * Set encoding tolerant mode as default on 8.7.x and off on TCL9.x - */ - - #if TCL_MAJOR_VERSION < 9 - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; - #endif - - /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and @@ -7913,20 +7905,16 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-strictencoding")) { + if (len == 0 || HaveOpt(1, "-strictencoding")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-strictencoding"); } - Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); - if (len > 0) { - return TCL_OK; - } + Tcl_DStringAppendElement(dsPtr,"0"); if (len > 0) { return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-translation")) { + if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); } @@ -8179,19 +8167,22 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(2, "-strictencoding")) { + } else if (HaveOpt(1, "-strictencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } if (newMode) { - statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; - } else { - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -strictencoding: only false allowed", + -1)); + } + return TCL_ERROR; } return TCL_OK; - } else if (HaveOpt(2, "-translation")) { + } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 54ffe0e..54aa5af 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,8 +271,6 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding - * is set to 0 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 178b54a..ad4cd4e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,6 +369,13 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). +test iocmd-8.21 {fconfigure command / -strictencoding 1 error} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -strictencoding 1 +} -returnCodes error -result "bad value for -strictencoding: only false allowed" + test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode @@ -1363,7 +1370,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1379,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1391,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index f848b58..a1c7aa4 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 393743bb7088f57b28cd5f98d2c9f70189807a2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Sep 2022 20:41:29 +0000 Subject: Start TIP #346 implementation: For now only \xC0\x80 --- generic/tcl.h | 1 + generic/tclCmdAH.c | 22 ++++++++++++++++------ generic/tclEncoding.c | 8 ++++++-- tests/cmdAH.test | 24 ++++++++++++------------ tests/encoding.test | 4 ++-- tests/safe.test | 8 ++++---- 6 files changed, 41 insertions(+), 26 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..acff803 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2118,6 +2118,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 +#define TCL_ENCODING_STRICT 0x44 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 28fc210..572a995 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -564,8 +564,10 @@ EncodingConvertfromObjCmd( * 2) encoding data -> objc = 3 * 3) -nocomplain data -> objc = 3 * 4) -nocomplain encoding data -> objc = 4 - * 5) -failindex val data -> objc = 4 - * 6) -failindex val encoding data -> objc = 5 + * 5) -strict data -> objc = 3 + * 6) -strict encoding data -> objc = 4 + * 7) -failindex val data -> objc = 4 + * 8) -failindex val encoding data -> objc = 5 */ if (objc == 2) { @@ -579,6 +581,10 @@ EncodingConvertfromObjCmd( && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { /* at least two additional arguments needed */ @@ -603,7 +609,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -621,7 +627,7 @@ EncodingConvertfromObjCmd( } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -714,6 +720,10 @@ EncodingConverttoObjCmd( && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { /* at least two additional arguments needed */ @@ -738,7 +748,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -749,7 +759,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { /* I hope, wide int will cover size_t data type */ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0ce75b4..9c4b5ce 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2288,7 +2288,7 @@ BinaryProc( */ #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR !(flags & TCL_ENCODING_NOCOMPLAIN) +# define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR)) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif @@ -2359,10 +2359,14 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && !(flags & TCL_ENCODING_MODIFIED)) { + && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { /* * Convert 0xC080 to real nulls when we are in output mode. */ + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + result = TCL_CONVERT_UNKNOWN; + break; + } *dst++ = 0; src += 2; diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ab1a8e6..64991af 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -237,10 +237,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -249,19 +249,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -269,12 +269,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -282,7 +282,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { diff --git a/tests/encoding.test b/tests/encoding.test index 6f11968..c8f409e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,10 +669,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/safe.test b/tests/safe.test index fc7c814..148215a 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From a312d4a759c7d925d22e4e4fc8cbbe2d23dc9f27 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Sep 2022 13:44:25 +0000 Subject: Add testcases, and fix a bug found by it --- generic/tclEncoding.c | 9 ++++++--- tests/cmdAH.test | 20 ++++++++++++++++++++ 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 9c4b5ce..3d5e474 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2361,13 +2361,16 @@ UtfToUtfProc( } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { /* - * Convert 0xC080 to real nulls when we are in output mode. + * If in input mode, and -strict is specified: This is an error. */ - if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + if (flags & TCL_ENCODING_MODIFIED) { result = TCL_CONVERT_UNKNOWN; break; - } + } + /* + * Convert 0xC080 to real nulls when we are in output mode, with or without '-strict'. + */ *dst++ = 0; src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 38ca521..69da6c2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -21,6 +21,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint time64bit [expr { $::tcl_platform(pointerSize) >= 8 || [llength [info command testsize]] && [testsize st_mtime] >= 8 @@ -349,6 +350,25 @@ test cmdAH-4.21.2 {convertto -failindex with wrong character (byte compiled)} -s } -returnCodes 0 -result {41 1} -cleanup { rename encoding_test "" } +test cmdAH-4.22 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.23 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\xC0\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\xC0'} + +test cmdAH-4.24 {convertto -strict} -body { + encoding convertto -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.25 {convertfrom -strict} -constraints knownBug -body { + encoding convertfrom -strict utf-8 A\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} + +test cmdAH-4.26 {convertto -strict} -constraints {testbytestring knownBug} -body { + encoding convertto -strict utf-8 A[testbytestring \x80]B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -- cgit v0.12 From 5d066cf1694f50526815d3b96301e4cf7f3007fd Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 19 Sep 2022 17:45:10 +0000 Subject: TIP633 fconfigure -nocomplainencoding (TCL8.7): replace "-strictencoding 0" by "-nocomplainencoding 1". --- generic/tclIO.c | 12 ++++++------ tests/ioCmd.test | 18 +++++++++--------- tests/zlib.test | 4 ++-- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 71ad637..3c1d4b0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7923,11 +7923,11 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0 || HaveOpt(1, "-nocomplainencoding")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); } - Tcl_DStringAppendElement(dsPtr,"0"); + Tcl_DStringAppendElement(dsPtr,"1"); if (len > 0) { return TCL_OK; } @@ -8185,16 +8185,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(1, "-strictencoding")) { + } else if (HaveOpt(1, "-nocomplainencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } - if (newMode) { + if (!newMode) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -strictencoding: only false allowed", + "bad value for -nocomplainencoding: only true allowed", -1)); } return TCL_ERROR; diff --git a/tests/ioCmd.test b/tests/ioCmd.test index ad4cd4e..0af12ce 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,12 +369,12 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -test iocmd-8.21 {fconfigure command / -strictencoding 1 error} -setup { +test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -setup { # I don't know how else to open the console, but this is non-portable set console stdin } -body { - fconfigure $console -strictencoding 1 -} -returnCodes error -result "bad value for -strictencoding: only false allowed" + fconfigure $console -nocomplainencoding 0 +} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" test iocmd-9.1 {eof command} { @@ -1370,7 +1370,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1379,7 +1379,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1391,7 +1391,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index a1c7aa4..6d71a81 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 606baf39a5ea4daea70730647a6c5e435db9df03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 11:26:44 +0000 Subject: Add -strictencoding option to channels. Thanks to Harald Oehlman for his example (largely copied). No testcases yet --- generic/tclIO.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclIO.h | 3 ++- tests/ioCmd.test | 12 ++++++------ tests/socket.test | 2 +- tests/zlib.test | 4 ++-- 5 files changed, 64 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e00b99b..04c3b1b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4342,6 +4342,14 @@ Write( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Write the terminated escape sequence even if srcLen is 0. */ @@ -4657,6 +4665,14 @@ Tcl_GetsObj( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5412,6 +5428,15 @@ FilterInputBytes( *gsPtr->dstPtr = dst; } gsPtr->state = statePtr->inputEncodingState; + + /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, @@ -6185,6 +6210,14 @@ ReadChars( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * This routine is burdened with satisfying several constraints. It cannot * append more than 'charsToRead` chars onto objPtr. This is measured * after encoding and translation transformations are completed. There is @@ -7920,6 +7953,16 @@ Tcl_GetChannelOption( return TCL_OK; } } + if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_STRICT) ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + } if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); @@ -8173,6 +8216,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; + } else if (HaveOpt(1, "-strictencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags |= CHANNEL_ENCODING_STRICT; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; diff --git a/generic/tclIO.h b/generic/tclIO.h index 54aa5af..7fbb19e 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,7 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ - +#define CHANNEL_ENCODING_STRICT (1<<18) /* set if option + * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..4b61fff 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..c354f46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 16 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" diff --git a/tests/zlib.test b/tests/zlib.test index 7de6d64..a1c7aa4 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 4721ffe64fe11287997ec892d58c375a73e3876d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Oct 2022 15:31:31 +0000 Subject: Fix [1599352cca] and related issues --- generic/tclDictObj.c | 51 ++++++++++++++++++++++++++------------------------- generic/tclInt.h | 2 +- generic/tclListObj.c | 7 ++++--- generic/tclUtil.c | 13 +++++++------ 4 files changed, 38 insertions(+), 35 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ba9ab98..3fe1800 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -265,7 +265,7 @@ DeleteChainTable( ChainEntry *cPtr; for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } @@ -312,7 +312,7 @@ DeleteChainEntry( if (cPtr == NULL) { return 0; } else { - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } @@ -364,7 +364,7 @@ DupDictInternalRep( Tcl_Obj *copyPtr) { Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *newDict = (Dict *)ckalloc(sizeof(Dict)); ChainEntry *cPtr; /* @@ -373,8 +373,8 @@ DupDictInternalRep( InitChainTable(newDict); for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { - Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry); - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *key = (Tcl_Obj *)Tcl_GetHashKey(&oldDict->table, &cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); int n; Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n); @@ -492,7 +492,8 @@ UpdateStringOfDict( Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int i, length, bytesNeeded = 0; + int i, length; + unsigned int bytesNeeded = 0; const char *elem; char *dst; @@ -517,7 +518,7 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = ckalloc(numElems); + flagPtr = (char *)ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* @@ -526,22 +527,22 @@ UpdateStringOfDict( */ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); - keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } flagPtr[i+1] = TCL_DONT_QUOTE_HASH; - valuePtr = Tcl_GetHashValue(&cPtr->entry); + valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -555,13 +556,13 @@ UpdateStringOfDict( dst = dictPtr->bytes; for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; - valuePtr = Tcl_GetHashValue(&cPtr->entry); + valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; @@ -600,7 +601,7 @@ SetDictFromAny( { Tcl_HashEntry *hPtr; int isNew; - Dict *dict = ckalloc(sizeof(Dict)); + Dict *dict = (Dict *)ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -625,7 +626,7 @@ SetDictFromAny( /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr); /* * Not really a well-formed dictionary as there are duplicate @@ -690,7 +691,7 @@ SetDictFromAny( /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, keyPtr, &isNew); if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr); TclDecrRefCount(keyPtr); TclDecrRefCount(discardedValue); @@ -809,7 +810,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); } else { - tmpObj = Tcl_GetHashValue(hPtr); + tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); if (tmpObj->typePtr != &tclDictType && SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; @@ -919,7 +920,7 @@ Tcl_DictObjPut( hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { - Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } @@ -969,7 +970,7 @@ Tcl_DictObjGet( if (hPtr == NULL) { *valuePtrPtr = NULL; } else { - *valuePtrPtr = Tcl_GetHashValue(hPtr); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); } return TCL_OK; } @@ -1115,10 +1116,10 @@ Tcl_DictObjFirst( searchPtr->next = cPtr->nextPtr; dict->refCount++; if (keyPtrPtr != NULL) { - *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); } } return TCL_OK; @@ -1181,7 +1182,7 @@ Tcl_DictObjNext( Tcl_Panic("concurrent dictionary modification and search"); } - cPtr = searchPtr->next; + cPtr = (ChainEntry *)searchPtr->next; if (cPtr == NULL) { Tcl_DictObjDone(searchPtr); *donePtr = 1; @@ -1191,11 +1192,11 @@ Tcl_DictObjNext( searchPtr->next = cPtr->nextPtr; *donePtr = 0; if (keyPtrPtr != NULL) { - *keyPtrPtr = Tcl_GetHashKey( + *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey( &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index 63fcf62..8c3efb5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3146,7 +3146,7 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE int TclScanElement(const char *string, int length, +MODULE_SCOPE unsigned int TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 88a332f..a994fd7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1945,7 +1945,8 @@ UpdateStringOfList( char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; + int i, length; + unsigned int bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **elemPtrs; @@ -1986,11 +1987,11 @@ UpdateStringOfList( flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8d2347b..cacd23e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1010,7 +1010,7 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -int +unsigned int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ @@ -1026,7 +1026,7 @@ TclScanElement( int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - int bytesNeeded; /* Buffer length computed to complete the + unsigned int bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1290,7 +1290,7 @@ TclScanElement( *flagPtr = CONVERT_NONE; overflowCheck: - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("TclScanElement: string length overflow"); } return bytesNeeded; @@ -1568,7 +1568,8 @@ Tcl_Merge( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i, bytesNeeded = 0; + int i; + unsigned int bytesNeeded = 0; char *result, *dst; /* @@ -1594,11 +1595,11 @@ Tcl_Merge( for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - argc + 1) { + if (bytesNeeded + argc > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; -- cgit v0.12 From 9dd5a63f35590c88db321bf5f70429c61ed5a3b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Oct 2022 13:12:11 +0000 Subject: TIP #640: Remove Tcl_SaveResult (in Tcl 8.7 it's only removed when compiled with -DTCL_NO_DEPRECATED) --- doc/SaveInterpState.3 | 85 ++++++++++++++++++++++++++++++++++++ doc/SaveResult.3 | 85 ------------------------------------ generic/tcl.h | 2 + generic/tclDecls.h | 29 +++--------- generic/tclTest.c | 8 ++++ macosx/Tcl.xcodeproj/project.pbxproj | 4 +- win/tcl.dsp | 2 +- 7 files changed, 105 insertions(+), 110 deletions(-) create mode 100644 doc/SaveInterpState.3 delete mode 100644 doc/SaveResult.3 diff --git a/doc/SaveInterpState.3 b/doc/SaveInterpState.3 new file mode 100644 index 0000000..804f9ec --- /dev/null +++ b/doc/SaveInterpState.3 @@ -0,0 +1,85 @@ +'\" +'\" Copyright (c) 1997 Sun Microsystems, Inc. +'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) +'\" Copyright (c) 2018 Nathan Coulter. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, +Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the +state of an an interpreter. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_InterpState +\fBTcl_SaveInterpState\fR(\fIinterp, status\fR) +.sp +int +\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) +.sp +\fBTcl_DiscardInterpState\fR(\fIstate\fR) +.sp +\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) +.SH ARGUMENTS +.AS Tcl_InterpState savedPtr +.AP Tcl_Interp *interp in +The interpreter for the operation. +.AP int status in +The return code for the state. +.AP Tcl_InterpState state in +A token for saved state. +.AP Tcl_SavedResult *savedPtr in +A pointer to storage for saved state. +.BE +.SH DESCRIPTION +.PP +These routines save the state of an interpreter before a call to a routine such +as \fBTcl_Eval\fR, and restore the state afterwards. +.PP +\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the +result of a script, including the resulting value, the return code passed as +\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. +It returns a token for the saved state. The interpreter result is not reset +and no interpreter state is changed. +.PP +\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and +returns the \fIstatus\fR originally passed in the corresponding call to +\fBTcl_SaveInterpState\fR. +.PP +If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called +to release it. A token used to discard or restore state must not be used +again. +.PP +\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are +deprecated. Instead use \fBTcl_SaveInterpState\fR, +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more +capable. +.PP +\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location +\fIstatePtr\fR points to and returns the interpreter result to its initial +state. It does not save options such as \fB\-errorcode\fR or +\fB\-errorinfo\fR. +.PP +\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and +moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is +then in an undefined state and must not be used until passed again to +\fBTcl_SaveResult\fR. +.PP +\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is +then in an undefined state and must not be used until passed again to +\fBTcl_SaveResult\fR. +.PP +If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to +release it. +.SH KEYWORDS +result, state, interp diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 deleted file mode 100644 index 804f9ec..0000000 --- a/doc/SaveResult.3 +++ /dev/null @@ -1,85 +0,0 @@ -'\" -'\" Copyright (c) 1997 Sun Microsystems, Inc. -'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) -'\" Copyright (c) 2018 Nathan Coulter. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, -Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the -state of an an interpreter. -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_InterpState -\fBTcl_SaveInterpState\fR(\fIinterp, status\fR) -.sp -int -\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) -.sp -\fBTcl_DiscardInterpState\fR(\fIstate\fR) -.sp -\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) -.SH ARGUMENTS -.AS Tcl_InterpState savedPtr -.AP Tcl_Interp *interp in -The interpreter for the operation. -.AP int status in -The return code for the state. -.AP Tcl_InterpState state in -A token for saved state. -.AP Tcl_SavedResult *savedPtr in -A pointer to storage for saved state. -.BE -.SH DESCRIPTION -.PP -These routines save the state of an interpreter before a call to a routine such -as \fBTcl_Eval\fR, and restore the state afterwards. -.PP -\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the -result of a script, including the resulting value, the return code passed as -\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. -It returns a token for the saved state. The interpreter result is not reset -and no interpreter state is changed. -.PP -\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and -returns the \fIstatus\fR originally passed in the corresponding call to -\fBTcl_SaveInterpState\fR. -.PP -If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called -to release it. A token used to discard or restore state must not be used -again. -.PP -\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are -deprecated. Instead use \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more -capable. -.PP -\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location -\fIstatePtr\fR points to and returns the interpreter result to its initial -state. It does not save options such as \fB\-errorcode\fR or -\fB\-errorinfo\fR. -.PP -\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -release it. -.SH KEYWORDS -result, state, interp diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..c8a76c5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -817,6 +817,7 @@ typedef struct Tcl_Obj { * typically allocated on the stack. */ +#ifndef TCL_NO_DEPRECATED typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; @@ -826,6 +827,7 @@ typedef struct Tcl_SavedResult { int appendUsed; char resultSpace[200+1]; } Tcl_SavedResult; +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 25adc95..62b9604 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -14,6 +14,10 @@ #include /* for size_t */ +#ifdef TCL_NO_DEPRECATED +# define Tcl_SavedResult void +#endif /* TCL_NO_DEPRECATED */ + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -4231,30 +4235,8 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult -static TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {} -#define Tcl_SaveResult(interp, statePtr) \ - do { \ - Tcl_SaveResult_(); \ - (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount((statePtr)->objResultPtr); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ - } while(0) #undef Tcl_RestoreResult -static TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {} -#define Tcl_RestoreResult(interp, statePtr) \ - do { \ - Tcl_RestoreResult_(); \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ - } while(0) #undef Tcl_DiscardResult -static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {} -#define Tcl_DiscardResult(statePtr) \ - do { \ - Tcl_DiscardResult_(); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ - } while(0) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ @@ -4492,6 +4474,9 @@ static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_( * Deprecated Tcl procedures: */ +#ifdef TCL_NO_DEPRECATED +# undef Tcl_SavedResult +#endif /* TCL_NO_DEPRECATED */ #undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) diff --git a/generic/tclTest.c b/generic/tclTest.c index 354ea9c..95f4d2f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -145,7 +145,9 @@ typedef struct { * was called for a result. */ +#ifndef TCL_NO_DEPRECATED static int freeCount; +#endif /* TCL_NO_DEPRECATED */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -297,8 +299,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -690,8 +694,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); +#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -5522,6 +5528,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -5635,6 +5642,7 @@ TestsaveresultFree( { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 90896e2..4143128 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -376,7 +376,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = rename.n; sourceTree = ""; }; F96D3E9208F272A6004A47F5 /* return.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = return.n; sourceTree = ""; }; F96D3E9308F272A6004A47F5 /* safe.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = safe.n; sourceTree = ""; }; - F96D3E9408F272A6004A47F5 /* SaveResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveResult.3; sourceTree = ""; }; + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveInterpState.3; sourceTree = ""; }; F96D3E9508F272A6004A47F5 /* scan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = scan.n; sourceTree = ""; }; F96D3E9608F272A6004A47F5 /* seek.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = seek.n; sourceTree = ""; }; F96D3E9708F272A6004A47F5 /* set.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = set.n; sourceTree = ""; }; @@ -1123,7 +1123,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */, F96D3E9208F272A6004A47F5 /* return.n */, F96D3E9308F272A6004A47F5 /* safe.n */, - F96D3E9408F272A6004A47F5 /* SaveResult.3 */, + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */, F96D3E9508F272A6004A47F5 /* scan.n */, F96D3E9608F272A6004A47F5 /* seek.n */, F93599D80DF1F98300E04F67 /* self.n */, diff --git a/win/tcl.dsp b/win/tcl.dsp index cc9d173..aff1000 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -760,7 +760,7 @@ SOURCE=..\doc\safe.n # End Source File # Begin Source File -SOURCE=..\doc\SaveResult.3 +SOURCE=..\doc\SaveInterpState.3 # End Source File # Begin Source File -- cgit v0.12 From 6f2284ab12177714d29ad979fa1f1420e61f836b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 10:18:33 +0000 Subject: Follow-up to [1599352cca]: Tcl_Merge(): out-of-bounds write, more signed integer overflow. Better panic message when argc < 0. --- generic/tclUtil.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index cacd23e..a8bf795 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1577,7 +1577,10 @@ Tcl_Merge( * simpler. */ - if (argc == 0) { + if (argc <= 0) { + if (argc < 0) { + Tcl_Panic("Tcl_Merge called with negative argc (%d)", argc); + } result = (char *)ckalloc(1); result[0] = '\0'; return result; -- cgit v0.12 From 948f556e5200e88aa563402d1f0ad7019d0c291b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 11:02:05 +0000 Subject: More -1 -> TCL_INDEX_NONE --- generic/tclUtil.c | 131 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 68 insertions(+), 63 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2b1305c..f10187b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -375,10 +375,10 @@ static const Tcl_ObjType endOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a - * full list parser. Typically used to get a quick and dirty overestimate - * of length size in order to allocate space for an actual list parser to - * operate with. + * separators. If 'numBytes' is TCL_INDEX_NONE, scan to the terminating + * '\0'. Not a full list parser. Typically used to get a quick and dirty + * overestimate of length size in order to allocate space for an actual + * list parser to operate with. * * Results: * Returns the largest number of list elements that could possibly be in @@ -399,7 +399,7 @@ TclMaxListLength( { int count = 0; - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { /* Empty string case - quick exit */ goto done; } @@ -415,7 +415,7 @@ TclMaxListLength( */ while (numBytes) { - if ((numBytes == -1) && (*bytes == '\0')) { + if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) { break; } if (TclIsSpaceProcM(*bytes)) { @@ -426,9 +426,9 @@ TclMaxListLength( count++; do { bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } while (numBytes && TclIsSpaceProcM(*bytes)); - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { break; } @@ -437,7 +437,7 @@ TclMaxListLength( */ } bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } /* @@ -874,7 +874,7 @@ Tcl_SplitList( * string gets re-purposed to hold '\0' characters in the argv array. */ - size = TclMaxListLength(list, -1, &end) + 1; + size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1; length = end - list; argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); @@ -897,7 +897,7 @@ Tcl_SplitList( ckfree(argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "internal error in Tcl_SplitList", -1)); + "internal error in Tcl_SplitList", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } @@ -945,9 +945,9 @@ int Tcl_ScanElement( const char *src, /* String to convert to list element. */ int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + * Tcl_ConvertCountedElement. */ { - return Tcl_ScanCountedElement(src, -1, flagPtr); + return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr); } /* @@ -958,8 +958,8 @@ Tcl_ScanElement( * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. + * list element. If length is TCL_INDEX_NONE, then the string is scanned + * from src up to the first null byte. * * Results: * The return value is an overestimate of the number of bytes that will @@ -976,7 +976,7 @@ Tcl_ScanElement( int Tcl_ScanCountedElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -995,7 +995,7 @@ Tcl_ScanCountedElement( * This function is a companion function to TclConvertElement. It scans a * string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. If - * length is -1, then the string is scanned from src up to the first null + * length is TCL_INDEX_NONE, then the string is scanned from src up to the first null * byte. A NULL value for src is treated as an empty string. The incoming * value of *flagPtr is a report from the caller what additional flags it * will pass to TclConvertElement(). @@ -1017,10 +1017,10 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclScanElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -1033,7 +1033,7 @@ TclScanElement( int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - unsigned int bytesNeeded; /* Buffer length computed to complete the + TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1041,7 +1041,7 @@ TclScanElement( int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ - if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) { /* * Empty string element must be brace quoted. */ @@ -1124,7 +1124,7 @@ TclScanElement( break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { + if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { /* * Final backslash. Cannot format with brace quoting. */ @@ -1155,7 +1155,7 @@ TclScanElement( #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ - if (length == -1) { + if (length == TCL_INDEX_NONE) { goto endOfString; } /* TODO: Panic on improper encoding? */ @@ -1330,7 +1330,7 @@ Tcl_ConvertElement( char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { - return Tcl_ConvertCountedElement(src, -1, dst, flags); + return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } /* @@ -1357,7 +1357,7 @@ Tcl_ConvertElement( int Tcl_ConvertCountedElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1390,7 +1390,7 @@ Tcl_ConvertCountedElement( int TclConvertElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1409,7 +1409,7 @@ TclConvertElement( * No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { + if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) { p[0] = '{'; p[1] = '}'; return 2; @@ -1436,7 +1436,7 @@ TclConvertElement( */ if (conversion == CONVERT_NONE) { - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1455,7 +1455,7 @@ TclConvertElement( if (conversion == CONVERT_BRACE) { *p = '{'; p++; - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1528,7 +1528,7 @@ TclConvertElement( p++; continue; case '\0': - if (length == -1) { + if (length == TCL_INDEX_NONE) { return p - dst; } @@ -1604,7 +1604,7 @@ Tcl_Merge( } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); - bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); + bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]); if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } @@ -1622,7 +1622,7 @@ Tcl_Merge( dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]); + dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]); *dst = ' '; dst++; } @@ -2665,8 +2665,8 @@ Tcl_DStringInit( char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *bytes, /* String to append. If length is -1 then this - * must be null-terminated. */ + const char *bytes, /* String to append. If length is + * < 0 then this must be null-terminated. */ int length) /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ @@ -2692,18 +2692,18 @@ Tcl_DStringAppend( memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - int offset = -1; + int index = TCL_INDEX_NONE; /* See [16896d49fd] */ if (bytes >= dsPtr->string && bytes <= dsPtr->string + dsPtr->length) { - offset = bytes - dsPtr->string; + index = bytes - dsPtr->string; } dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); - if (offset >= 0) { - bytes = dsPtr->string + offset; + if (index >= 0) { + bytes = dsPtr->string + index; } } } @@ -2802,7 +2802,7 @@ Tcl_DStringAppendElement( if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } - newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); + newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags); if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } @@ -2851,7 +2851,7 @@ Tcl_DStringAppendElement( dsPtr->length++; } - dsPtr->length += TclConvertElement(element, -1, dst, flags); + dsPtr->length += TclConvertElement(element, TCL_INDEX_NONE, dst, flags); dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -3263,7 +3263,7 @@ Tcl_PrintDouble( */ if (*precisionPtr == 0) { - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { /* @@ -3637,11 +3637,11 @@ TclFormatInt( static int GetWideForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ + * NULL, then no error message is left after + * errors. */ Tcl_Obj *objPtr, /* Points to the value to be parsed */ size_t endValue, /* The value to be stored at *widePtr if - * objPtr holds "end". + * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ @@ -3673,21 +3673,26 @@ GetWideForIndex( * * Tcl_GetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. + * Value + * TCL_OK * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ @@ -3711,7 +3716,7 @@ Tcl_GetIntForIndex( } if (indexPtr != NULL) { if ((wide < 0) && (endValue >= 0)) { - *indexPtr = -1; + *indexPtr = TCL_INDEX_NONE; } else if (wide > INT_MAX) { *indexPtr = INT_MAX; } else if (wide < INT_MIN) { @@ -3788,7 +3793,7 @@ GetEndOffsetFromObj( * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ - if ((TclMaxListLength(bytes, -1, NULL) > 1) + if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) /* If it's possible, do the full list parse. */ && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length)) @@ -3797,7 +3802,7 @@ GetEndOffsetFromObj( } /* Passed the list screen, so parse for index arithmetic expression */ - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr, TCL_PARSE_INTEGER_ONLY)) { Tcl_WideInt w1=0, w2=0; @@ -3813,7 +3818,7 @@ GetEndOffsetFromObj( } if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, - -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + TCL_INDEX_NONE, NULL, TCL_PARSE_INTEGER_ONLY)) { /* ... value concludes with second valid integer */ /* Save second integer as wide if possible */ @@ -4172,7 +4177,7 @@ TclCheckBadOctal( */ Tcl_AppendToObj(Tcl_GetObjResult(interp), - " (looks like invalid octal number)", -1); + " (looks like invalid octal number)", TCL_INDEX_NONE); } return 1; } @@ -4794,7 +4799,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); -- cgit v0.12 From a9fba66be576e55d089b69f8531d514cdc05c61e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 7 Oct 2022 11:23:18 +0000 Subject: Add memory leak/refcount tests for lists, spans and lseq --- generic/tclTestObj.c | 323 ++++++++++++++++++++++++++++++++++----------------- tests/listObj.test | 68 +++++++++++ 2 files changed, 284 insertions(+), 107 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a03a60a..93af3c0 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -841,6 +841,35 @@ TestintobjCmd( * test a few possible corner cases in list object manipulation from * C code that cannot occur at the Tcl level. * + * Following new commands are added for 8.7 as regression tests for + * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal + * representations for lists. It has to be ensured that corresponding + * implementations obey the invariants of the C list API. The script + * level tests do not suffice as Tcl list commands do not execute + * the same exact code path as the exported C API. + * + * Note these new commands are only useful when Tcl is compiled with + * TCL_MEM_DEBUG defined. + * + * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This + * is to test that abstract lists returning elements do not depend + * on caller to free them. The test case should check allocated counts + * with the following sequence: + * set before + * testobj set VARINDEX [list a b c] (or lseq etc.) + * testlistobj indexnoop VARINDEX + * testobj unset VARINDEX + * set after + * after calling this command AND freeing the passed list. The targeted + * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference + * resulting in a memory leak. Conversely, the command also checks + * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference + * count since it is supposed to have at least one reference held + * by the list implementation. Returns a message in interp otherwise. + * + * getelementsmemcheck - as above but for Tcl_ListObjGetElements + + * * Results: * A standard Tcl object result. * @@ -861,25 +890,36 @@ TestlistobjCmd( const char* subcommands[] = { "set", "get", - "replace" + "replace", + "indexmemcheck", + "getelementsmemcheck", + NULL }; enum listobjCmdIndex { LISTOBJ_SET, LISTOBJ_GET, - LISTOBJ_REPLACE + LISTOBJ_REPLACE, + LISTOBJ_INDEXMEMCHECK, + LISTOBJ_GETELEMENTSMEMCHECK, } cmdIndex; size_t varIndex; /* Variable number converted to binary */ Tcl_WideInt first; /* First index in the list */ Tcl_WideInt count; /* Count of elements in a list */ Tcl_Obj **varPtr; + int i; +#if TCL_VERSION_MAJOR < 9 + int len; +#else + size_t len; +#endif if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); return TCL_ERROR; } varPtr = GetVarPtr(interp); - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -923,6 +963,58 @@ TestlistobjCmd( Tcl_ResetResult(interp); return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, objc-5, objv+5); + + case LISTOBJ_INDEXMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + Tcl_Obj *objP; + if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP) + != TCL_OK) { + return TCL_ERROR; + } + if (objP->refCount <= 0) { + Tcl_SetResult( + interp, + "Tcl_ListObjIndex returned object with ref count <= 0", + TCL_STATIC); + /* Keep looping since we are also looping for leaks */ + } + } + break; + + case LISTOBJ_GETELEMENTSMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } else { + Tcl_Obj **elems; + if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems) + != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + if (elems[i]->refCount <= 0) { + Tcl_SetResult( + interp, + "Tcl_ListObjGetElements element has ref count <= 0", + TCL_STATIC); + break; + } + } + } + break; } return TCL_OK; } @@ -953,9 +1045,21 @@ TestobjCmd( { size_t varIndex, destIndex; int i; - const char *subCmd; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; + const char *subcommands[] = { + "freeallvars", "bug3598580", "types", + "objtype", "newobj", "set", + "assign", "convert", "duplicate", + "invalidateStringRep", "refcount", "type", + NULL + }; + enum testobjCmdIndex { + TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES, + TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, + TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, + TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, + } cmdIndex; if (objc < 2) { wrongNumArgs: @@ -964,142 +1068,159 @@ TestobjCmd( } varPtr = GetVarPtr(interp); - subCmd = Tcl_GetString(objv[1]); - if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { + if (Tcl_GetIndexFromObj( + interp, objv[1], subcommands, "command", 0, &cmdIndex) + != TCL_OK) { + return TCL_ERROR; + } + switch (cmdIndex) { + case TESTOBJ_FREEALLVARS: + if (objc != 2) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } } - if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_BUG3598580: + if (objc != 2) { + goto wrongNumArgs; + } else { + Tcl_Obj *listObjPtr, *elemObjPtr; + elemObjPtr = Tcl_NewWideIntObj(123); + listObjPtr = Tcl_NewListObj(1, &elemObjPtr); + /* Replace the single list element through itself, nonsense but + * legal. */ + Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); + Tcl_SetObjResult(interp, listObjPtr); } - SetVarToObj(varPtr, destIndex, varPtr[varIndex]); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "bug3598580") == 0) { - Tcl_Obj *listObjPtr, *elemObjPtr; + return TCL_OK; + case TESTOBJ_TYPES: if (objc != 2) { goto wrongNumArgs; + } else { + Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL); + Tcl_AppendAllObjTypes(interp, typesObj); + Tcl_SetObjResult(interp, typesObj); } - elemObjPtr = Tcl_NewWideIntObj(123); - listObjPtr = Tcl_NewListObj(1, &elemObjPtr); - /* Replace the single list element through itself, nonsense but legal. */ - Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); - Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; - } else if (strcmp(subCmd, "convert") == 0) { + case TESTOBJ_OBJTYPE: + /* + * Return an object containing the name of the argument's type of + * internal rep. If none exists, return "none". + */ - if (objc != 4) { + if (objc != 3) { goto wrongNumArgs; + } else { + const char *typeName; + + if (objv[2]->typePtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); + } + else { + typeName = objv[2]->typePtr->name; + if (!strcmp(typeName, "utf32string")) + typeName = "string"; +#ifndef TCL_WIDE_INT_IS_LONG + else if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); + } } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", Tcl_GetString(objv[3]), " found", NULL); - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_NEWOBJ: + if (objc != 3) { + goto wrongNumArgs; } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "duplicate") == 0) { + return TCL_OK; + case TESTOBJ_SET: if (objc != 4) { goto wrongNumArgs; } if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + SetVarToObj(varPtr, varIndex, objv[3]); + return TCL_OK; + + default: + break; + } + + /* All further commands expect an occupied varindex argument */ + if (objc < 3) { + goto wrongNumArgs; + } + + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + + switch (cmdIndex) { + case TESTOBJ_ASSIGN: + if (objc != 4) { + goto wrongNumArgs; } if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if (strcmp(subCmd, "invalidateStringRep") == 0) { - if (objc != 3) { + break; + case TESTOBJ_CONVERT: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no type ", Tcl_GetString(objv[3]), " found", NULL); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { return TCL_ERROR; } - Tcl_InvalidateStringRep(varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { + break; + case TESTOBJ_DUPLICATE: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "objtype") == 0) { - const char *typeName; - - /* - * Return an object containing the name of the argument's type of - * internal rep. If none exists, return "none". - */ - + SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + Tcl_SetObjResult(interp, varPtr[destIndex]); + break; + case TESTOBJ_INVALIDATESTRINGREP: if (objc != 3) { goto wrongNumArgs; } - if (objv[2]->typePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); - } else { - typeName = objv[2]->typePtr->name; - if (!strcmp(typeName, "utf32string")) typeName = "string"; -#ifndef TCL_WIDE_INT_IS_LONG - else if (!strcmp(typeName, "wideInt")) typeName = "int"; -#endif - Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); - } - } else if (strcmp(subCmd, "refcount") == 0) { + Tcl_InvalidateStringRep(varPtr[varIndex]); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case TESTOBJ_REFCOUNT: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); - } else if (strcmp(subCmd, "type") == 0) { + break; + case TESTOBJ_TYPE: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); #ifndef TCL_WIDE_INT_IS_LONG @@ -1111,21 +1232,9 @@ TestobjCmd( Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } - } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - if (Tcl_AppendAllObjTypes(interp, - Tcl_GetObjResult(interp)) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetString(objv[1]), - "\": must be assign, convert, duplicate, freeallvars, " - "newobj, objcount, objtype, refcount, type, or types", NULL); - return TCL_ERROR; + break; } + return TCL_OK; } diff --git a/tests/listObj.test b/tests/listObj.test index 0b64635..0f43648 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint memory [llength [info commands memory]] catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { @@ -210,6 +211,73 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj testobj bug3598580 } 123 +# Stolen from dict.test +proc listobjmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} +} + +test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + +test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 4b6d8abfe47494263e6fde30cbb9e9d9f880086e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 15:18:36 +0000 Subject: Use GotFlag/SetFlag/ResetFlag macro's wherever appropriate --- generic/tclIO.c | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5dff604..408a1d3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1478,7 +1478,7 @@ Tcl_GetChannel( chanPtr = (Channel *)Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { - *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE); } return (Tcl_Channel) chanPtr; @@ -1572,7 +1572,7 @@ TclGetChannelFromObj( *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; if (modePtr != NULL) { - *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } return TCL_OK; @@ -1877,7 +1877,7 @@ Tcl_StackChannel( * --+---+---+---+----+ */ - if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { + if ((mask & GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE)) == 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "reading and writing both disallowed for channel \"%s\"", @@ -2170,8 +2170,8 @@ Tcl_UnstackChannel( * TIP #220: This is done with maximum privileges (as created). */ - statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE); - statePtr->flags |= statePtr->maxPerms; + ResetFlag(statePtr, TCL_READABLE|TCL_WRITABLE); + SetFlag(statePtr, statePtr->maxPerms); result = ChanClose(chanPtr, interp); ChannelFree(chanPtr); @@ -2378,7 +2378,7 @@ Tcl_GetChannelMode( ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ - return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); + return GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } /* @@ -2481,12 +2481,12 @@ Tcl_RemoveChannelMode( emsg = "Illegal mode value."; goto error; } - if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) { + if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) { emsg = "Bad mode, would make channel inacessible"; goto error; } - statePtr->flags &= ~mode; + ResetFlag(statePtr, mode); return TCL_OK; error: @@ -3706,7 +3706,7 @@ Tcl_CloseEx( * opened for that direction). */ - if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) { + if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & flags)) { const char *msg; if (flags & TCL_CLOSE_READ) { @@ -6416,7 +6416,7 @@ ReadChars( return 1; } - } else if (statePtr->flags & CHANNEL_EOF) { + } else if (GotFlag(statePtr, CHANNEL_EOF)) { /* * The bare \r is the only char and we will never read a * subsequent char to make the determination. @@ -6682,7 +6682,7 @@ TranslateInputEOL( char *dst = dstStart; int lesser; - if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } @@ -7452,7 +7452,7 @@ CheckChannelErrors( * Fail if the channel is not opened for desired operation. */ - if ((statePtr->flags & direction) == 0) { + if (GotFlag(statePtr, direction) == 0) { Tcl_SetErrno(EACCES); return -1; } @@ -9138,7 +9138,7 @@ Tcl_FileEventObjCmd( } chanPtr = (Channel *) chan; statePtr = chanPtr->state; - if ((statePtr->flags & mask) == 0) { + if (GotFlag(statePtr, mask) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; @@ -9305,8 +9305,8 @@ TclCopyChannel( * Make sure the output side is unbuffered. */ - outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED) - | CHANNEL_UNBUFFERED; + ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED); + SetFlag(outStatePtr, CHANNEL_UNBUFFERED); /* * Test for conditions where we know we can just move bytes from input @@ -10085,7 +10085,7 @@ DoRead( * There's no more buffered data... */ - if (statePtr->flags & CHANNEL_EOF) { + if (GotFlag(statePtr, CHANNEL_EOF)) { /* * ...and there never will be. */ @@ -10093,7 +10093,7 @@ DoRead( *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; - } else if (statePtr->flags & CHANNEL_BLOCKED) { + } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) { /* * ...and we cannot get more now. */ @@ -10226,20 +10226,20 @@ StopCopy( */ nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->readPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } if (csPtr->readPtr != csPtr->writePtr) { nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(outStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); - outStatePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + SetFlag(outStatePtr, + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED)); if (csPtr->cmdPtr) { Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); -- cgit v0.12 From 12f23af5456f4a87b8bc4d58f9dcfc0edf2c9676 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 15:19:36 +0000 Subject: On Windows, env(HOME) should be handled case-insensitive in fCmd.test --- tests/fCmd.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index 73118f4..8c9f799 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2598,8 +2598,8 @@ test fCmd-31.6 {file home USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file home $::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file home $::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-31.7 {file home UNKNOWNUSER} -body { file home nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2640,8 +2640,8 @@ test fCmd-32.5 {file tildeexpand ~USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file tildeexpand ~$::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2655,8 +2655,8 @@ test fCmd-32.9 {file tildeexpand ~USER/bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)/bar -} -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)/bar] +} -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser/foo } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2679,8 +2679,8 @@ test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)\\bar -} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)\\bar] +} -constraints win -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] # cleanup -- cgit v0.12 From 5e4013330a16bddc87cd9179fce996982e333f20 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 8 Oct 2022 00:10:13 +0000 Subject: -nocomplainencoding and -strictencoding are incompatible --- generic/tclIO.c | 23 +++++++++++++++++++++-- generic/tclIO.h | 2 ++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 85067f2..ca12d63 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8009,7 +8009,8 @@ Tcl_GetChannelOption( if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); } - Tcl_DStringAppendElement(dsPtr,"1"); + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_STRICT) ? "0" : "1"); if (len > 0) { return TCL_OK; } @@ -8283,7 +8284,17 @@ Tcl_SetChannelOption( if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } - if (!newMode) { + if (newMode) { + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-nocomplainencoding cannot be used with -strictencoding", + -1)); + } + return TCL_ERROR; + } + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -nocomplainencoding: only true allowed", @@ -8299,6 +8310,14 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { + if (statePtr->flags & CHANNEL_ENCODING_NOCOMPLAIN) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-strictencoding cannot be used with -nocomplainencoding", + -1)); + } + return TCL_ERROR; + } statePtr->flags |= CHANNEL_ENCODING_STRICT; } return TCL_OK; diff --git a/generic/tclIO.h b/generic/tclIO.h index b86dc1d..e8d2736 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -273,6 +273,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option + * -nocomplaincoding is set to 1 */ #define CHANNEL_ENCODING_STRICT (1<<18) /* set if option * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. -- cgit v0.12 From bd8e0ee8b7e71085e6e3ff9a22dbc8b2b28a77f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 8 Oct 2022 17:01:35 +0000 Subject: TIP #346 bugfix: -strictencoding should be resetable too --- generic/tclIO.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 42c9e18..a13f32c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4399,6 +4399,8 @@ Write( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -4722,6 +4724,8 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -5487,6 +5491,8 @@ FilterInputBytes( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, @@ -6267,6 +6273,8 @@ ReadChars( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -8276,6 +8284,8 @@ Tcl_SetChannelOption( } if (newMode) { SetFlag(statePtr, CHANNEL_ENCODING_STRICT); + } else { + ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); } return TCL_OK; } else if (HaveOpt(1, "-translation")) { -- cgit v0.12 From a2b119cac88f2853439b6781404687c40acae4d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 9 Oct 2022 20:57:30 +0000 Subject: Tcl_NewWideIntObj -> Tcl_NewBooleanObj where appropriate --- generic/tclTest.c | 28 ++++++++++++++-------------- generic/tclTestObj.c | 12 ++++++------ generic/tclTestProcBodyObj.c | 2 +- 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 95f4d2f..539c90f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2941,7 +2941,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "int", &intVar, TCL_LINK_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2949,7 +2949,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "real", &realVar, TCL_LINK_DOUBLE | flag) != TCL_OK) { return TCL_ERROR; @@ -2957,7 +2957,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "bool", &boolVar, TCL_LINK_BOOLEAN | flag) != TCL_OK) { return TCL_ERROR; @@ -2965,7 +2965,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "string", &stringVar, TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; @@ -2973,7 +2973,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2981,7 +2981,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "char", &charVar, TCL_LINK_CHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2989,7 +2989,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uchar", &ucharVar, TCL_LINK_UCHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2997,7 +2997,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "short", &shortVar, TCL_LINK_SHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -3005,7 +3005,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ushort", &ushortVar, TCL_LINK_USHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -3013,7 +3013,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uint", &uintVar, TCL_LINK_UINT | flag) != TCL_OK) { return TCL_ERROR; @@ -3021,7 +3021,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "long", &longVar, TCL_LINK_LONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3029,7 +3029,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ulong", &ulongVar, TCL_LINK_ULONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3037,7 +3037,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "float", &floatVar, TCL_LINK_FLOAT | flag) != TCL_OK) { return TCL_ERROR; @@ -3045,7 +3045,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uwide", &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 721237b..c9a910a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -292,9 +292,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; @@ -387,9 +387,9 @@ TestbooleanobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); + Tcl_SetBooleanObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { @@ -412,9 +412,9 @@ TestbooleanobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 38cfaaa..844ff1b 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -340,7 +340,7 @@ ProcBodyTestCheckObjCmd( } version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( strcmp(version, packageVersion) == 0)); return TCL_OK; } -- cgit v0.12 From 3f7f7c5584f701f2fee77dc372b824b15b1a7739 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Oct 2022 11:08:38 +0000 Subject: Slight improvement to TIP #346/#633 combination: Now -strictencoding 1 automatically sets -nocomplainencoding to 0, while -nocomplainencoding 1 automatically sets strictencoding to 0. This way, they can never both be set. --- generic/tclIO.c | 30 +++++++++--------------------- 1 file changed, 9 insertions(+), 21 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 407b586..6a9c306 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8320,25 +8320,20 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-nocomplainencoding cannot be used with -strictencoding", - -1)); - } - return TCL_ERROR; - } + ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } else { #ifdef TCL_NO_DEPRECATED ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); #else - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -nocomplainencoding: only true allowed", - -1)); + if (SetFlag(statePtr, CHANNEL_ENCODING_STRICT)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -nocomplainencoding: only true allowed", + TCL_INDEX_NONE)); + } + return TCL_ERROR; } - return TCL_ERROR; #endif } return TCL_OK; @@ -8349,14 +8344,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-strictencoding cannot be used with -nocomplainencoding", - -1)); - } - return TCL_ERROR; - } + ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); SetFlag(statePtr, CHANNEL_ENCODING_STRICT); } else { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); -- cgit v0.12 From f2b3bc2aa5ebb89635fdb896e9ec4f67bbff445c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Oct 2022 15:19:59 +0000 Subject: Use Tcl_ObjCmdProc in stead of full signature --- generic/tclClock.c | 64 +++--- generic/tclExecute.c | 4 +- generic/tclIndexObj.c | 12 +- generic/tclInt.h | 452 +++++++++++-------------------------------- generic/tclProcess.c | 24 +-- generic/tclTestProcBodyObj.c | 6 +- generic/tclThreadTest.c | 4 +- generic/tclVar.c | 54 +++--- 8 files changed, 178 insertions(+), 442 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 86eed73..a9ba70c 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -160,39 +160,19 @@ static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int); static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int); static int IsGregorianLeapYear(TclDateFields *); static int WeekdayOnOrBefore(int, int); -static int ClockClicksObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockConvertlocaltoutcObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetdatefieldsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetjuliandayfromerayearmonthdayObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetjuliandayfromerayearweekdayObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetenvObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockMicrosecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockMillisecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockParseformatargsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockSecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ClockClicksObjCmd; +static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd; +static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd; +static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd; +static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd; +static Tcl_ObjCmdProc ClockGetenvObjCmd; +static Tcl_ObjCmdProc ClockMicrosecondsObjCmd; +static Tcl_ObjCmdProc ClockMillisecondsObjCmd; +static Tcl_ObjCmdProc ClockParseformatargsObjCmd; +static Tcl_ObjCmdProc ClockSecondsObjCmd; static struct tm * ThreadSafeLocalTime(const time_t *); static void TzsetIfNecessary(void); -static void ClockDeleteCmdProc(ClientData); +static void ClockDeleteCmdProc(void *); /* * Structure containing description of "native" clock commands to create. @@ -331,7 +311,7 @@ TclClockInit( static int ClockConvertlocaltoutcObjCmd( - ClientData clientData, /* Client data */ + void *clientData, /* Client data */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -423,7 +403,7 @@ ClockConvertlocaltoutcObjCmd( int ClockGetdatefieldsObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -577,7 +557,7 @@ FetchIntField( static int ClockGetjuliandayfromerayearmonthdayObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -661,7 +641,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( static int ClockGetjuliandayfromerayearweekdayObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -1645,7 +1625,7 @@ WeekdayOnOrBefore( int ClockGetenvObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1748,7 +1728,7 @@ ThreadSafeLocalTime( int ClockClicksObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1818,7 +1798,7 @@ ClockClicksObjCmd( int ClockMillisecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1855,7 +1835,7 @@ ClockMillisecondsObjCmd( int ClockMicrosecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1888,7 +1868,7 @@ ClockMicrosecondsObjCmd( static int ClockParseformatargsObjCmd( - ClientData clientData, /* Client data containing literal pool */ + void *clientData, /* Client data containing literal pool */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ @@ -2006,7 +1986,7 @@ ClockParseformatargsObjCmd( int ClockSecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -2106,7 +2086,7 @@ TzsetIfNecessary(void) static void ClockDeleteCmdProc( - ClientData clientData) /* Opaque pointer to the client data */ + void *clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData *)clientData; int i; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7c7bbfd..a063aae 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -670,9 +670,7 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); */ #ifdef TCL_COMPILE_STATS -static int EvalStatsCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc EvalStatsCmd; #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 70c50cd..79be731 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -25,15 +25,9 @@ static int GetIndexFromObjList(Tcl_Interp *interp, static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); -static int PrefixAllObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixLongestObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixMatchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc PrefixAllObjCmd; +static Tcl_ObjCmdProc PrefixLongestObjCmd; +static Tcl_ObjCmdProc PrefixMatchObjCmd; static void PrintUsage(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable); diff --git a/generic/tclInt.h b/generic/tclInt.h index e43e627..471892b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3223,17 +3223,12 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); -MODULE_SCOPE int TclInfoExistsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoCoroutineCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); -MODULE_SCOPE int TclInfoGlobalsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); @@ -3544,61 +3539,31 @@ MODULE_SCOPE int TclIsSpaceProc(int byte); *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_AppendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ApplyObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_BreakObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd; #if !defined(TCL_NO_DEPRECATED) -MODULE_SCOPE int Tcl_CaseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd; #endif -MODULE_SCOPE int Tcl_CatchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclChanCreateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPostEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); -MODULE_SCOPE int TclClockOldscanObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); -MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, @@ -3606,244 +3571,91 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd; MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_EofObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ErrorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_EvalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExecObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExprObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FblockedObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FconfigureObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FcopyObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd; MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_FileEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FlushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FormatObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GetsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IncrObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForeachObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FormatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GetsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobalObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_IfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_IncrObjCmd; MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_InterpObjCmd(void *clientData, - Tcl_Interp *interp, int argc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_JoinObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LeditObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LinsertObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LlengthObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ListObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LmapObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LoadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LseqObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_InterpObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_JoinObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LappendObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LassignObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LeditObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LindexObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LinsertObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LlengthObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ListObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LmapObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LoadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LpopObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrangeObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LremoveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd; MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclNamespaceEnsembleCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_OpenObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PackageObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PidObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNamespaceEnsembleCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_OpenObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PackageObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PidObjCmd; MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_PutsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PwdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegexpObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegsubObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RenameObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RepresentationCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReturnObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ScanObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SeekObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SplitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SocketObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SourceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PutsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PwdObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegexpObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegsubObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RenameObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RepresentationCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReturnObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ScanObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SeekObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SplitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SocketObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SourceObjCmd; MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_SubstObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SwitchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TellObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ThrowObjCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeRateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TraceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TryObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnloadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpdateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UplevelObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpvarObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VariableObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VwaitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_WhileObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SubstObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SwitchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TellObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ThrowObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeRateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TraceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TryObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnloadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnsetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpdateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UplevelObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpvarObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_VariableObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_VwaitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_WhileObjCmd; /* *---------------------------------------------------------------- @@ -4173,105 +3985,71 @@ MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInvertOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd; MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNotOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNotOpCmd; MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAddOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclAddOpCmd; MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMulOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclMulOpCmd; MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAndOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclAndOpCmd; MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclOrOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclOrOpCmd; MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclXorOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclXorOpCmd; MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclPowOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclPowOpCmd; MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclLshiftOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclLshiftOpCmd; MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclRshiftOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclRshiftOpCmd; MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclModOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclModOpCmd; MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNeqOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNeqOpCmd; MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclStrneqOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclStrneqOpCmd; MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInOpCmd; MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNiOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNiOpCmd; MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMinusOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclMinusOpCmd; MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclDivOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclDivOpCmd; MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 65c087c..aec8c0a 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -51,18 +51,10 @@ static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); -static int ProcessListObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ProcessListObjCmd; +static Tcl_ObjCmdProc ProcessStatusObjCmd; +static Tcl_ObjCmdProc ProcessPurgeObjCmd; +static Tcl_ObjCmdProc ProcessAutopurgeObjCmd; /* *---------------------------------------------------------------------- @@ -402,7 +394,7 @@ BuildProcessStatusObj( static int ProcessListObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -453,7 +445,7 @@ ProcessListObjCmd( static int ProcessStatusObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -601,7 +593,7 @@ ProcessStatusObjCmd( static int ProcessPurgeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -701,7 +693,7 @@ ProcessPurgeObjCmd( static int ProcessAutopurgeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 844ff1b..9b6aa1d 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -45,10 +45,8 @@ typedef struct CmdTable { * Declarations for functions defined in this file. */ -static int ProcBodyTestProcObjCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ProcBodyTestCheckObjCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ProcBodyTestProcObjCmd; +static Tcl_ObjCmdProc ProcBodyTestCheckObjCmd; static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, const char *namesp, const CmdTable *cmdTablePtr); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index cf9d0da..03446c2 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -119,9 +119,7 @@ static char *errorProcString; TCL_DECLARE_MUTEX(threadMutex) -static int ThreadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ThreadObjCmd; static int ThreadCreate(Tcl_Interp *interp, const char *script, int joinable); static int ThreadList(Tcl_Interp *interp); diff --git a/generic/tclVar.c b/generic/tclVar.c index 2ef51b2..2a96fb6 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -212,9 +212,7 @@ static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, * TIP #508: [array default] */ -static int ArrayDefaultCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ArrayDefaultCmd; static void DeleteArrayVar(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); @@ -1524,7 +1522,7 @@ TclPtrGetVarIdx( int Tcl_SetObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2818,7 +2816,7 @@ UnsetVarStruct( int Tcl_UnsetObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2885,7 +2883,7 @@ Tcl_UnsetObjCmd( int Tcl_AppendObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2950,7 +2948,7 @@ Tcl_AppendObjCmd( int Tcl_LappendObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3156,7 +3154,7 @@ ArrayObjNext( static int ArrayForObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3166,7 +3164,7 @@ ArrayForObjCmd( static int ArrayForNRCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -3237,7 +3235,7 @@ ArrayForNRCmd( static int ArrayForLoopCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -3395,7 +3393,7 @@ ArrayPopulateSearch( static int ArrayStartSearchCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3490,7 +3488,7 @@ ArrayDoneSearch( static int ArrayAnyMoreCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3568,7 +3566,7 @@ ArrayAnyMoreCmd( static int ArrayNextElementCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3648,7 +3646,7 @@ ArrayNextElementCmd( static int ArrayDoneSearchCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3708,7 +3706,7 @@ ArrayDoneSearchCmd( static int ArrayExistsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3748,7 +3746,7 @@ ArrayExistsCmd( static int ArrayGetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3907,7 +3905,7 @@ ArrayGetCmd( static int ArrayNamesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4074,7 +4072,7 @@ TclFindArrayPtrElements( static int ArraySetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4249,7 +4247,7 @@ ArraySetCmd( static int ArraySizeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4308,7 +4306,7 @@ ArraySizeCmd( static int ArrayStatsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4362,7 +4360,7 @@ ArrayStatsCmd( static int ArrayUnsetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4987,7 +4985,7 @@ Tcl_GetVariableFullName( int Tcl_GlobalObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -5091,7 +5089,7 @@ Tcl_GlobalObjCmd( int Tcl_VariableObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -5224,7 +5222,7 @@ Tcl_VariableObjCmd( int Tcl_UpvarObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6036,7 +6034,7 @@ ObjFindNamespaceVar( int TclInfoVarsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6227,7 +6225,7 @@ TclInfoVarsCmd( int TclInfoGlobalsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6320,7 +6318,7 @@ TclInfoGlobalsCmd( int TclInfoLocalsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6625,7 +6623,7 @@ CompareVarKeys( static int ArrayDefaultCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ -- cgit v0.12 From 763c581edb801f34c61cce8eadcf7d8904b3cce9 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 10 Oct 2022 15:37:23 +0000 Subject: Bugfix library/http/http.tcl for connection request header - tcllib/websocket ticket [d01de3281f]. Revise header order in 3 tests. --- library/http/http.tcl | 37 ++++++++++++++++++++++++++++++------- tests/http.test | 6 +++--- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 326aede..88685ec 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1260,6 +1260,7 @@ proc http::CreateToken {url args} { [GetFieldValue $state(-headers) Upgrade]] set state(upgradeRequest) [expr { "upgrade" in $connectionValues && [llength $upgradeValues] >= 1}] + set state(connectionValues) $connectionValues if {$isQuery || $isQueryChannel} { # It's a POST. @@ -2104,24 +2105,25 @@ proc http::Connected {token proto phost srvurl} { if {($state(-protocol) > 1.0) && $state(-keepalive)} { # Send this header, because a 1.1 server is not compelled to treat # this as the default. - SendHeader $token Connection keep-alive - } - if {($state(-protocol) > 1.0) && !$state(-keepalive)} { - SendHeader $token Connection close ;# RFC2616 sec 8.1.2.1 - } - if {($state(-protocol) < 1.1)} { + set ConnVal keep-alive + } elseif {($state(-protocol) > 1.0)} { + # RFC2616 sec 8.1.2.1 + set ConnVal close + } else { + # ($state(-protocol) <= 1.0) # RFC7230 A.1 # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". - SendHeader $token Connection close + set ConnVal close } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 + set connection_seen 0 foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string map {" " -} [string trim $key]] @@ -2141,6 +2143,24 @@ proc http::Connected {token proto phost srvurl} { set contDone 1 set state(querylength) $value } + if {[string equal -nocase $key "connection"]} { + # Remove "close" or "keep-alive" and use our own value. + # In an upgrade request, the upgrade is not guaranteed. + # Value "close" or "keep-alive" tells the server what to do + # if it refuses the upgrade. We send a single "Connection" + # header because some websocket servers, e.g. civetweb, reject + # multiple headers. Bug [d01de3281f] of tcllib/websocket. + set connection_seen 1 + set listVal $state(connectionValues) + if {[set pos [lsearch $listVal close]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + if {[set pos [lsearch $listVal keep-alive]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + lappend listVal $ConnVal + set value [join $listVal {, }] + } if {[string length $key]} { SendHeader $token $key $value } @@ -2159,6 +2179,9 @@ proc http::Connected {token proto phost srvurl} { SendHeader $token Accept-Encoding identity } else { } + if {!$connection_seen} { + SendHeader $token Connection $ConnVal + } if {$isQueryChannel && ($state(querylength) == 0)} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us diff --git a/tests/http.test b/tests/http.test index e88210a..1218536 100644 --- a/tests/http.test +++ b/tests/http.test @@ -409,10 +409,10 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} test http-3.28 {http::geturl: -headers override -type default} -body { set token [http::geturl $url/headers -query dummy \ @@ -422,10 +422,10 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} test http-3.29 {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is @@ -462,9 +462,9 @@ test http-3.32 {http::geturl: -headers override -accept default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Accept text/plain,application/tcl-test-value Accept-Encoding .* +Connection close Content-Type application/x-www-form-urlencoded Content-Length 5} # Bug 838e99a76d -- cgit v0.12 From 0d0cf6602a9b466d777c22736156422c586c8c94 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 06:26:44 +0000 Subject: There's a duplicate set of io-75.* testcases, so renumber one of them --- tests/io.test | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/io.test b/tests/io.test index 96abadd..f928cd3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9052,7 +9052,7 @@ test io-75.5 {incomplete shiftjis encoding read is ignored} -setup { -test io-75.0 {channel modes} -setup { +test io-76.0 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9062,7 +9062,7 @@ test io-75.0 {channel modes} -setup { removeFile dummy } -result {read {}} -test io-75.1 {channel modes} -setup { +test io-76.1 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9072,7 +9072,7 @@ test io-75.1 {channel modes} -setup { removeFile dummy } -result {{} write} -test io-75.2 {channel modes} -setup { +test io-76.2 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9082,7 +9082,7 @@ test io-75.2 {channel modes} -setup { removeFile dummy } -result {read write} -test io-75.3 {channel mode dropping} -setup { +test io-76.3 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9093,7 +9093,7 @@ test io-75.3 {channel mode dropping} -setup { removeFile dummy } -result {{read {}} {read {}}} -test io-75.4 {channel mode dropping} -setup { +test io-76.4 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9103,7 +9103,7 @@ test io-75.4 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.5 {channel mode dropping} -setup { +test io-76.5 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9114,7 +9114,7 @@ test io-75.5 {channel mode dropping} -setup { removeFile dummy } -result {{{} write} {{} write}} -test io-75.6 {channel mode dropping} -setup { +test io-76.6 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9124,7 +9124,7 @@ test io-75.6 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.7 {channel mode dropping} -setup { +test io-76.7 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9135,7 +9135,7 @@ test io-75.7 {channel mode dropping} -setup { removeFile dummy } -result {{{} write} {read write}} -test io-75.8 {channel mode dropping} -setup { +test io-76.8 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9146,7 +9146,7 @@ test io-75.8 {channel mode dropping} -setup { removeFile dummy } -result {{read {}} {read write}} -test io-75.9 {channel mode dropping} -setup { +test io-76.9 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9157,7 +9157,7 @@ test io-75.9 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.10 {channel mode dropping} -setup { +test io-76.10 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { -- cgit v0.12 From 75ba8ac33bf8e8e9c0dfed189d177ebb6710dd15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 11:02:45 +0000 Subject: Format errors in vwait.n --- doc/vwait.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/vwait.n b/doc/vwait.n index 5f240d6..d67c16d 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -13,7 +13,7 @@ vwait \- Process events until a variable is written .SH SYNOPSIS \fBvwait\fR \fIvarName\fR .PP -\fBvwait\fR ?\Ioptions\fR? ?\fIvarName ...\fR? +\fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR? .BE .SH DESCRIPTION .PP @@ -66,7 +66,7 @@ Events of the windowing system are not handled during the wait operation. \fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR is or becomes readable the wait operation completes. .TP -\fB\-timeout\fR milliseconds\fR +\fB\-timeout\fR \fImilliseconds\fR . The wait operation is constrained to \fImilliseconds\fR. .TP -- cgit v0.12 From d4c0a2c2ae26239197650eaaf6388d7ccdc51e48 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 14:22:17 +0000 Subject: Few more formatting errors --- doc/http.n | 6 +----- doc/vwait.n | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/doc/http.n b/doc/http.n index c08d221..59f15b6 100644 --- a/doc/http.n +++ b/doc/http.n @@ -613,13 +613,11 @@ The "request line" is the first line of a HTTP client request, and has three elements separated by spaces: the HTTP method, the URL relative to the server, and the HTTP version. Examples: .PP -.DS .RS GET / HTTP/1.1 GET /introduction.html?subject=plumbing HTTP/1.1 POST /forms/order.html HTTP/1.1 .RE -.DE .TP \fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR? . @@ -650,12 +648,10 @@ elements separated by spaces: the HTTP version, a three-digit numerical "status code", and a "reason phrase". Only the reason phrase may contain spaces. Examples: .PP -.DS .RS HTTP/1.1 200 OK HTTP/1.0 404 Not Found .RE -.DE .RS The "status code" is a three-digit number in the range 100 to 599. A value of 200 is the normal return from a GET request, and its matching @@ -1589,7 +1585,7 @@ that \fB::tls::socketCmd\fR has this value, it replaces it with the value i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value. The script or installation that modified \fB::tls::socketCmd\fR is responsible -for integrating \fR::http::socket\fR into its own replacement command. +for integrating \fB::http::socket\fR into its own replacement command. .PP .SS "WITH A CHILD INTERPRETER" .PP diff --git a/doc/vwait.n b/doc/vwait.n index d67c16d..e595a74 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -12,7 +12,7 @@ vwait \- Process events until a variable is written .SH SYNOPSIS \fBvwait\fR \fIvarName\fR -.PP +.sp \fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR? .BE .SH DESCRIPTION -- cgit v0.12 From b758c501cf323af7a0fddb806260e84ad03c68e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 15:51:42 +0000 Subject: Document TCL_ENCODING_STRICT flag --- doc/Encoding.3 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 86c5a78..553cc21 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -114,7 +114,9 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has +automatically be substituted. The flag \fBTCL_ENCODING_STRICT\fR makes the +encoder/decoder more strict in what it considers to be an invalid byte +sequence. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes \fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. -- cgit v0.12