From 4391b633d94f7d36fc07107753bac88a29504488 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Oct 2022 15:07:33 +0000 Subject: TIP 644 - Make Tcl_ObjType extensible --- generic/tcl.h | 5 +++++ generic/tclArithSeries.c | 3 ++- generic/tclAssembly.c | 3 ++- generic/tclBinary.c | 3 ++- generic/tclCompile.c | 4 +++- generic/tclDictObj.c | 3 ++- generic/tclDisassemble.c | 1 + generic/tclEncoding.c | 8 +++++++- generic/tclEnsemble.c | 3 ++- generic/tclExecute.c | 5 +++-- generic/tclIO.c | 3 ++- generic/tclIndexObj.c | 3 ++- generic/tclLink.c | 3 ++- generic/tclListObj.c | 3 ++- generic/tclNamesp.c | 3 ++- generic/tclOOCall.c | 3 ++- generic/tclObj.c | 15 ++++++++++----- generic/tclPathObj.c | 3 ++- generic/tclProc.c | 8 +++++--- generic/tclRegexp.c | 3 ++- generic/tclStringObj.c | 3 ++- generic/tclUtil.c | 3 ++- generic/tclVar.c | 4 ++-- 23 files changed, 66 insertions(+), 29 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 80494f3..f1d27ef 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -616,7 +616,12 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ + unsigned char version; } Tcl_ObjType; +#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init + * when existing code that does not init this field + * is compiled with Tcl9 headers */ +#define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0 /* * The following structure stores an internal representation (internalrep) for diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index d88c8ed..65807c3 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -75,7 +75,8 @@ const Tcl_ObjType tclArithSeriesType = { FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny /* setFromAnyProc */ + SetArithSeriesFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b7bfd2d..9448162 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -325,7 +325,8 @@ static const Tcl_ObjType assembleCodeType = { FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a7d6617..7e2634c 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -162,7 +162,8 @@ static const Tcl_ObjType properByteArrayType = { FreeProperByteArrayInternalRep, DupProperByteArrayInternalRep, UpdateStringOfByteArray, - NULL + NULL, + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a57743c..fc2b6b7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -708,7 +708,8 @@ const Tcl_ObjType tclByteCodeType = { FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ + SetByteCodeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -722,6 +723,7 @@ static const Tcl_ObjType substCodeType = { DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ca2501c..26f98e1 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -146,7 +146,8 @@ const Tcl_ObjType tclDictType = { FreeDictInternalRep, /* freeIntRepProc */ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny /* setFromAnyProc */ + SetDictFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define DictSetInternalRep(objPtr, dictRepPtr) \ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 8fd90a3..9670b84 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,6 +42,7 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0, }; #define InstNameSetInternalRep(objPtr, inst) \ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e366904..7e7c1a6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -236,8 +236,14 @@ static Tcl_EncodingConvertProc Iso88591ToUtfProc; */ static const Tcl_ObjType encodingType = { - "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL + "encoding", + FreeEncodingInternalRep, + DupEncodingInternalRep, + NULL, + NULL, + TCL_OBJTYPE_V0, }; + #define EncodingSetInternalRep(objPtr, encoding) \ do { \ Tcl_ObjInternalRep ir; \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 8bb90da..44179cf 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -81,7 +81,8 @@ static const Tcl_ObjType ensembleCmdType = { FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4b9ed0d..2ec0337 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -663,7 +663,8 @@ static const Tcl_ObjType exprCodeType = { FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -674,7 +675,7 @@ static const Tcl_ObjType exprCodeType = { static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, - NULL, NULL, NULL + NULL, NULL, NULL, TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclIO.c b/generic/tclIO.c index 5f831c9..8d54045 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -332,7 +332,8 @@ static const Tcl_ObjType chanObjType = { FreeChannelInternalRep, /* freeIntRepProc */ DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define ChanSetInternalRep(objPtr, resPtr) \ diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index aab7820..58bcc04 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -41,7 +41,8 @@ static const Tcl_ObjType indexType = { FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 2649d12..d184700 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -114,7 +114,8 @@ static Tcl_ObjType invalidRealType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 14f6132..06a316f 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -155,7 +155,8 @@ const Tcl_ObjType tclListType = { FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ - SetListFromAny /* setFromAnyProc */ + SetListFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* Macros to manipulate the List internal rep */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 979426c..1882e0a 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -130,7 +130,8 @@ static const Tcl_ObjType nsNameType = { FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetNsNameFromAny /* setFromAnyProc */ + SetNsNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define NsNameSetInternalRep(objPtr, nnPtr) \ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 912c368..450fc9f 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -150,7 +150,8 @@ static const Tcl_ObjType methodNameType = { FreeMethodNameRep, DupMethodNameRep, NULL, - NULL + NULL, + TCL_OBJTYPE_V0 }; diff --git a/generic/tclObj.c b/generic/tclObj.c index 5e55784..eeaa727 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -230,28 +230,32 @@ const Tcl_ObjType tclBooleanType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclDoubleType = { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ + SetDoubleFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclIntType = { "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ + SetIntFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -295,7 +299,8 @@ Tcl_ObjType tclCmdNameType = { FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ + SetCmdNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 40955b1..17bbc46 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -41,7 +41,8 @@ static const Tcl_ObjType fsPathType = { FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny /* setFromAnyProc */ + SetFsPathFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclProc.c b/generic/tclProc.c index acb520c..a9baba2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -63,8 +63,9 @@ const Tcl_ObjType tclProcBodyType = { NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic * instead. */ - NULL /* SetFromAny function; Tcl_ConvertToType + NULL, /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ + TCL_OBJTYPE_V0 }; #define ProcSetIntRep(objPtr, procPtr) \ @@ -93,7 +94,7 @@ const Tcl_ObjType tclProcBodyType = { static const Tcl_ObjType levelReferenceType = { "levelReference", - NULL, NULL, NULL, NULL + NULL, NULL, NULL, NULL, TCL_OBJTYPE_V0 }; /* @@ -110,7 +111,8 @@ static const Tcl_ObjType lambdaType = { FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetLambdaFromAny /* setFromAnyProc */ + SetLambdaFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 5fe5412..259e3f7 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -106,7 +106,8 @@ const Tcl_ObjType tclRegexpType = { FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetRegexpFromAny /* setFromAnyProc */ + SetRegexpFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define RegexpSetInternalRep(objPtr, rePtr) \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index cf23aab..fb7e45a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -90,7 +90,8 @@ const Tcl_ObjType tclStringType = { FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ - SetStringFromAny /* setFromAnyProc */ + SetStringFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5870781..cdaa242 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -127,7 +127,8 @@ static const Tcl_ObjType endOffsetType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 337f923..6226e1e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -245,7 +245,7 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL + FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define LocalSetInternalRep(objPtr, index, namePtr) \ @@ -268,7 +268,7 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL + FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ -- cgit v0.12 From c8a85bbc05960b91123999e18cdf1c872896dec7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Oct 2022 09:01:36 +0000 Subject: Change version field to Tcl_ObjTypeVersion --- generic/tcl.h | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 4def1b3..3f54c6d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -360,6 +360,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; +typedef struct Tcl_ObjTypeVersion_ *Tcl_ObjTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; typedef struct Tcl_Dict_ *Tcl_Dict; @@ -616,11 +617,11 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ - unsigned char version; + Tcl_ObjTypeVersion version; } Tcl_ObjType; -#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init - * when existing code that does not init this field - * is compiled with Tcl9 headers */ +#define TCL_OBJTYPE_V0 ((Tcl_ObjTypeVersion)0) /* Pre-Tcl 9. Set to 0 so + * compiler will auto-init when existing code that does + * not init this field is compiled with Tcl9 headers */ #define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0 /* -- cgit v0.12 From b07c7ad8aea461d1e2e16c66029fbaa43d05d54c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Nov 2022 20:27:51 +0000 Subject: Update Tcl_Filesystem documentation --- ChangeLog.2008 | 2 +- doc/FileSystem.3 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ChangeLog.2008 b/ChangeLog.2008 index 9c4e951..53690e4 100644 --- a/ChangeLog.2008 +++ b/ChangeLog.2008 @@ -1939,7 +1939,7 @@ 2008-07-28 Jan Nijtmans * doc/FileSystem.3: CONSTified many functions using - * generic/tcl.decls: Tcl_FileSystem which all are supposed + * generic/tcl.decls: Tcl_Filesystem which all are supposed * generic/tclDecls.h: to be a constant, but this was not * generic/tclFileSystem.h: reflected in the API: Tcl_FSData, * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister, diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 239ff0f..469af22 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -850,7 +850,7 @@ The \fBTcl_Filesystem\fR structure contains the following fields: .CS typedef struct Tcl_Filesystem { const char *\fItypeName\fR; - int \fIstructureLength\fR; + size_t \fIstructureLength\fR; Tcl_FSVersion \fIversion\fR; Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR; Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR; -- cgit v0.12 From fac57136f20a8c4ace9517a25a77be701705827e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Nov 2022 21:01:12 +0000 Subject: Remove TclpHasSockets(): Every system nowadays has sockets --- generic/tclIOCmd.c | 4 +- generic/tclInt.decls | 7 +- generic/tclInt.h | 1 + generic/tclIntDecls.h | 8 +- generic/tclStubInit.c | 2 +- unix/tclUnixSock.c | 23 ------ win/tclWinSock.c | 216 ++++++++++---------------------------------------- 7 files changed, 51 insertions(+), 210 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e706f40..4ce27bb 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1455,9 +1455,7 @@ Tcl_SocketObjCmd( Tcl_Obj *script = NULL; Tcl_Channel chan; - if (TclpHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } + TclInitSockets(); for (a = 1; a < objc; a++) { const char *arg = TclGetString(objv[a]); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 1bd462d..d9bd5c5 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -330,9 +330,10 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 132 { - int TclpHasSockets(Tcl_Interp *interp) -} +# Removed in 9.0: +#declare 132 { +# int TclpHasSockets(Tcl_Interp *interp) +#} # Removed in 9.0: #declare 133 { # struct tm *TclpGetDate(const time_t *time, int useGMT) diff --git a/generic/tclInt.h b/generic/tclInt.h index a17ce7d..dbe44b5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3276,6 +3276,7 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +MODULE_SCOPE void TclInitSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index b84b996..eaa7d95 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -292,8 +292,7 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* 132 */ -EXTERN int TclpHasSockets(Tcl_Interp *interp); +/* Slot 132 is reserved */ /* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ @@ -721,7 +720,7 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ - int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ + void (*reserved132)(void); void (*reserved133)(void); void (*reserved134)(void); void (*reserved135)(void); @@ -1058,8 +1057,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ -#define TclpHasSockets \ - (tclIntStubsPtr->tclpHasSockets) /* 132 */ +/* Slot 132 is reserved */ /* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4b2fd30..a1d0541 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -531,7 +531,7 @@ static const TclIntStubs tclIntStubs = { Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ - TclpHasSockets, /* 132 */ + 0, /* 132 */ 0, /* 133 */ 0, /* 134 */ 0, /* 135 */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index de4d9a8..864d477 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -319,29 +319,6 @@ Tcl_GetHostName(void) /* * ---------------------------------------------------------------------- * - * TclpHasSockets -- - * - * Detect if sockets are available on this platform. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * None. - * - * ---------------------------------------------------------------------- - */ - -int -TclpHasSockets( - TCL_UNUSED(Tcl_Interp *)) -{ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclpFinalizeSockets -- * * Performs per-thread socket subsystem finalization. diff --git a/win/tclWinSock.c b/win/tclWinSock.c index d9cff72..3c82caa 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -234,7 +234,6 @@ static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); -static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, @@ -362,23 +361,22 @@ InitializeHostName( Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ + TclInitSockets(); + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - Tcl_DString inDs; + Tcl_DString inDs; - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), - TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds); - } - Tcl_DStringFree(&inDs); + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), + TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds); } + Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); @@ -415,11 +413,9 @@ Tcl_GetHostName(void) /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TclInitSockets -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function just calls InitSockets(), but is protected by a mutex. * * Results: * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an @@ -433,24 +429,16 @@ Tcl_GetHostName(void) *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ +void +TclInitSockets() { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", TCL_INDEX_NONE)); + if (!initialized) { + Tcl_MutexLock(&socketMutex); + if (!initialized) { + InitSockets(); + } + Tcl_MutexUnlock(&socketMutex); } - return TCL_ERROR; } /* @@ -775,17 +763,6 @@ TcpInputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ @@ -918,17 +895,6 @@ TcpOutputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * Check if there is an async connect running. * For blocking sockets terminate connect, otherwise do one step. * For a non blocking socket return EWOULDBLOCK if connect not terminated @@ -1029,28 +995,20 @@ TcpCloseProc( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. */ - if (SocketsEnabled()) { - /* - * Clean up the OS socket handle. The default Windows setting for a - * socket is SO_DONTLINGER, which does a graceful shutdown in the - * background. - */ - - while (statePtr->sockets != NULL) { - TcpFdList *thisfd = statePtr->sockets; + while (statePtr->sockets != NULL) { + TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; - if (closesocket(thisfd->fd) == SOCKET_ERROR) { - Tcl_WinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - Tcl_Free(thisfd); + statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + Tcl_WinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } + Tcl_Free(thisfd); } if (statePtr->addrlist != NULL) { @@ -1177,20 +1135,6 @@ TcpSetOptionProc( len = strlen(optionName); } - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - sock = statePtr->sockets->fd; if ((len > 1) && (optionName[1] == 'k') && @@ -1277,20 +1221,6 @@ TcpGetOptionProc( #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - - /* * Go one step in async connect * * If any error is thrown save it as backround error to report eventually @@ -2013,19 +1943,7 @@ Tcl_OpenTcpClient( struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Do the name lookups for the local and remote addresses. @@ -2099,9 +2017,7 @@ Tcl_MakeTcpClientChannel( char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; - if (TclpHasSockets(NULL) != TCL_OK) { - return NULL; - } + TclInitSockets(); tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -2167,19 +2083,7 @@ Tcl_OpenTcpServerEx( const char *errorMsg = NULL; int optvalue, port; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Construct the addresses for each end of the socket. @@ -2510,55 +2414,19 @@ InitSockets(void) WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + if (tsdPtr->hwnd != NULL) { + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; } - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - initFailure: - TclpFinalizeSockets(); - initialized = -1; + Tcl_Panic("InitSockets failed"); return; } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- - * - * Check that the WinSock was successfully initialized. - * - * Warning: - * This check was useful in times of Windows98 where WinSock may - * not be available. This is not the case any more. - * This function may be removed with TCL 9.0 - * - * Results: - * 1 if it is. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SocketsEnabled(void) -{ - int enabled; - - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} - - -/* - *---------------------------------------------------------------------- - * * SocketExitHandler -- * * Callback invoked during exit clean up to delete the socket @@ -3388,9 +3256,7 @@ TcpThreadActionProc( * sockets will not work. */ - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TclInitSockets(); tsdPtr = TCL_TSD_INIT(&dataKey); -- cgit v0.12 From 44ce8c245fa83b3cc8733db27a99b24bdca732fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 10:50:39 +0000 Subject: TclInitSockets() only exists on Windows --- generic/tclInt.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index dbe44b5..a633a17 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3276,7 +3276,11 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +#ifdef _WIN32 MODULE_SCOPE void TclInitSockets(void); +#else +#define TclInitSockets() /* do nothing */ +#endif MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, -- cgit v0.12 From 82a4bb8618f4a8672fd62a895fa355c1a0628b88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 20:46:49 +0000 Subject: Deprecate TclpHasSockets(): Every system nowadays has sockets --- ChangeLog.2008 | 2 +- generic/tclCompCmdsGR.c | 25 +++--- generic/tclCompile.c | 2 +- generic/tclIOCmd.c | 61 +++++++------- generic/tclInt.decls | 2 +- generic/tclInt.h | 5 ++ generic/tclIntDecls.h | 5 +- generic/tclStubInit.c | 3 + unix/tclUnixSock.c | 27 +----- win/tclWinSock.c | 216 +++++++++--------------------------------------- 10 files changed, 102 insertions(+), 246 deletions(-) diff --git a/ChangeLog.2008 b/ChangeLog.2008 index 9c4e951..53690e4 100644 --- a/ChangeLog.2008 +++ b/ChangeLog.2008 @@ -1939,7 +1939,7 @@ 2008-07-28 Jan Nijtmans * doc/FileSystem.3: CONSTified many functions using - * generic/tcl.decls: Tcl_FileSystem which all are supposed + * generic/tcl.decls: Tcl_Filesystem which all are supposed * generic/tclDecls.h: to be a constant, but this was not * generic/tclFileSystem.h: reflected in the API: Tcl_FSData, * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2681d01..7bb06ab 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -181,7 +181,8 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + int numBytes, j; + int jumpFalseDist, numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ @@ -1361,7 +1362,7 @@ TclCompileLinsertCmd( if (parsePtr->numWords < 3) { return TCL_ERROR; } - + /* Push list, insertion index onto the stack */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -1376,7 +1377,7 @@ TclCompileLinsertCmd( /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); - /* + /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element * TCL_LREPLACE4_SINGLE_INDEX - second index is not present @@ -1430,7 +1431,7 @@ TclCompileLreplaceCmd( /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); - /* + /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element */ @@ -1438,7 +1439,7 @@ TclCompileLreplaceCmd( return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -1924,7 +1925,8 @@ TclCompileRegexpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; + int len; + int i, nocase, exact, sawLast, simple; const char *str; /* @@ -2110,7 +2112,8 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, quantified, result = TCL_ERROR; + int exact, quantified, result = TCL_ERROR; + int len; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2264,7 +2267,8 @@ TclCompileReturnCmd( * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level, code, objc, size, status = TCL_OK; + int level, code, objc, status = TCL_OK; + int size; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; @@ -2374,7 +2378,7 @@ TclCompileReturnCmd( ExceptionRange range = envPtr->exceptArrayPtr[index]; if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { + && (range.catchOffset == TCL_INDEX_NONE)) { enclosingCatch = 1; break; } @@ -2700,7 +2704,8 @@ IndexTailVarIfKnown( { Tcl_Obj *tailPtr; const char *tailName, *p; - int len, n = varTokenPtr->numComponents; + int n = varTokenPtr->numComponents; + int len; Tcl_Token *lastTokenPtr; int full, localIndex; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2dd0718..c10145c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -678,7 +678,7 @@ InstructionDesc const tclInstructionTable[] = { {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags - * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj + * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not * set in flags. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 0ea84f1..e8a534f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -15,7 +15,7 @@ * Callback structure for accept callback in a TCP server. */ -typedef struct AcceptCallback { +typedef struct { Tcl_Obj *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -44,7 +44,7 @@ static void RegisterTcpServerInterpCleanup( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc; -static void TcpServerCloseProc(ClientData callbackData); +static void TcpServerCloseProc(void *callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); @@ -67,7 +67,7 @@ static void UnregisterTcpServerInterpCleanupProc( static void FinalizeIOCmdTSD( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -97,7 +97,7 @@ FinalizeIOCmdTSD( int Tcl_PutsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -223,7 +223,7 @@ Tcl_PutsObjCmd( int Tcl_FlushObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -287,7 +287,7 @@ Tcl_FlushObjCmd( int Tcl_GetsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -335,7 +335,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - lineLen = -1; + lineLen = TCL_INDEX_NONE; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, @@ -371,7 +371,7 @@ Tcl_GetsObjCmd( int Tcl_ReadObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -514,7 +514,7 @@ Tcl_ReadObjCmd( int Tcl_SeekObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -589,7 +589,7 @@ Tcl_SeekObjCmd( int Tcl_TellObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -651,7 +651,7 @@ Tcl_TellObjCmd( int Tcl_CloseObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -759,7 +759,7 @@ Tcl_CloseObjCmd( int Tcl_FconfigureObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -834,7 +834,7 @@ Tcl_FconfigureObjCmd( int Tcl_EofObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -873,7 +873,7 @@ Tcl_EofObjCmd( int Tcl_ExecObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -883,8 +883,8 @@ Tcl_ExecObjCmd( * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; + int argc, background, i, index, keepNewline, result, skip, ignoreStderr; + int length; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; @@ -1040,7 +1040,7 @@ Tcl_ExecObjCmd( int Tcl_FblockedObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1086,7 +1086,7 @@ Tcl_FblockedObjCmd( int Tcl_OpenObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1144,7 +1144,8 @@ Tcl_OpenObjCmd( if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { - int mode, seekFlag, cmdObjc, binary; + int mode, seekFlag, binary; + int cmdObjc; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { @@ -1209,7 +1210,7 @@ Tcl_OpenObjCmd( static void TcpAcceptCallbacksDeleteProc( - ClientData clientData, /* Data which was passed when the assocdata + void *clientData, /* Data which was passed when the assocdata * was registered. */ TCL_UNUSED(Tcl_Interp *)) { @@ -1337,7 +1338,7 @@ UnregisterTcpServerInterpCleanupProc( static void AcceptCallbackProc( - ClientData callbackData, /* The data stored when the callback was + void *callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted @@ -1428,7 +1429,7 @@ AcceptCallbackProc( static void TcpServerCloseProc( - ClientData callbackData) /* The data passed in the call to + void *callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; @@ -1461,7 +1462,7 @@ TcpServerCloseProc( int Tcl_SocketObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1481,9 +1482,7 @@ Tcl_SocketObjCmd( Tcl_Obj *script = NULL; Tcl_Channel chan; - if (TclpHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } + TclInitSockets(); for (a = 1; a < objc; a++) { const char *arg = Tcl_GetString(objv[a]); @@ -1714,7 +1713,7 @@ Tcl_SocketObjCmd( int Tcl_FcopyObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1809,7 +1808,7 @@ Tcl_FcopyObjCmd( static int ChanPendingObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1871,7 +1870,7 @@ ChanPendingObjCmd( static int ChanTruncateObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1944,7 +1943,7 @@ ChanTruncateObjCmd( static int ChanPipeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1995,7 +1994,7 @@ ChanPipeObjCmd( int TclChannelNamesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index d16a74c..c0e0e06 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -321,7 +321,7 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 132 { +declare 132 {deprecated {}} { int TclpHasSockets(Tcl_Interp *interp) } declare 133 {deprecated {}} { diff --git a/generic/tclInt.h b/generic/tclInt.h index 6af0991..bdd7e5a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3294,6 +3294,11 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +#ifdef _WIN32 +MODULE_SCOPE void TclInitSockets(void); +#else +#define TclInitSockets() /* do nothing */ +#endif MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ec9023f..3da8567 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -354,7 +354,8 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ -EXTERN int TclpHasSockets(Tcl_Interp *interp); +TCL_DEPRECATED("") +int TclpHasSockets(Tcl_Interp *interp); /* 133 */ TCL_DEPRECATED("") struct tm * TclpGetDate(const time_t *time, int useGMT); @@ -801,7 +802,7 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ - int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ + TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1ffe916..7af42d3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -795,6 +795,7 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # undef TclBN_s_mp_sub # define TclBN_s_mp_sub 0 # define Tcl_MakeSafe 0 +# define TclpHasSockets 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld @@ -818,6 +819,8 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define TclpGmtime_unix TclpGmtime # define Tcl_MakeSafe TclMakeSafe +int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;} + static int seekOld( Tcl_Channel chan, /* The channel on which to seek. */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 4e34af5..70dfc61 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -322,29 +322,6 @@ Tcl_GetHostName(void) /* * ---------------------------------------------------------------------- * - * TclpHasSockets -- - * - * Detect if sockets are available on this platform. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * None. - * - * ---------------------------------------------------------------------- - */ - -int -TclpHasSockets( - TCL_UNUSED(Tcl_Interp *)) -{ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclpFinalizeSockets -- * * Performs per-thread socket subsystem finalization. @@ -541,7 +518,7 @@ TcpInputProc( if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0); + bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0); if (bytesRead >= 0) { return bytesRead; } @@ -591,7 +568,7 @@ TcpOutputProc( if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); + written = send(statePtr->fds.fd, buf, toWrite, 0); if (written >= 0) { return written; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 9ac1a15..ef01fa8 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -234,7 +234,6 @@ static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); -static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, @@ -366,23 +365,22 @@ InitializeHostName( Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ + TclInitSockets(); + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - Tcl_DString inDs; + Tcl_DString inDs; - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), - TCL_INDEX_NONE, &ds); - } - Tcl_DStringFree(&inDs); + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), + TCL_INDEX_NONE, &ds); } + Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); @@ -419,11 +417,9 @@ Tcl_GetHostName(void) /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TclInitSockets -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function just calls InitSockets(), but is protected by a mutex. * * Results: * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an @@ -437,24 +433,16 @@ Tcl_GetHostName(void) *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ +void +TclInitSockets() { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", TCL_INDEX_NONE)); + if (!initialized) { + Tcl_MutexLock(&socketMutex); + if (!initialized) { + InitSockets(); + } + Tcl_MutexUnlock(&socketMutex); } - return TCL_ERROR; } /* @@ -779,17 +767,6 @@ TcpInputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ @@ -922,17 +899,6 @@ TcpOutputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * Check if there is an async connect running. * For blocking sockets terminate connect, otherwise do one step. * For a non blocking socket return EWOULDBLOCK if connect not terminated @@ -1033,28 +999,20 @@ TcpCloseProc( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. */ - if (SocketsEnabled()) { - /* - * Clean up the OS socket handle. The default Windows setting for a - * socket is SO_DONTLINGER, which does a graceful shutdown in the - * background. - */ - - while (statePtr->sockets != NULL) { - TcpFdList *thisfd = statePtr->sockets; + while (statePtr->sockets != NULL) { + TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; - if (closesocket(thisfd->fd) == SOCKET_ERROR) { - Tcl_WinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - ckfree(thisfd); + statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + Tcl_WinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } + ckfree(thisfd); } if (statePtr->addrlist != NULL) { @@ -1181,20 +1139,6 @@ TcpSetOptionProc( len = strlen(optionName); } - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - sock = statePtr->sockets->fd; if ((len > 1) && (optionName[1] == 'k') && @@ -1281,20 +1225,6 @@ TcpGetOptionProc( #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - - /* * Go one step in async connect * * If any error is thrown save it as backround error to report eventually @@ -2017,19 +1947,7 @@ Tcl_OpenTcpClient( struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Do the name lookups for the local and remote addresses. @@ -2103,9 +2021,7 @@ Tcl_MakeTcpClientChannel( char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; - if (TclpHasSockets(NULL) != TCL_OK) { - return NULL; - } + TclInitSockets(); tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -2171,19 +2087,7 @@ Tcl_OpenTcpServerEx( const char *errorMsg = NULL; int optvalue, port; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Construct the addresses for each end of the socket. @@ -2514,55 +2418,19 @@ InitSockets(void) WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + if (tsdPtr->hwnd != NULL) { + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; } - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - initFailure: - TclpFinalizeSockets(); - initialized = -1; + Tcl_Panic("InitSockets failed"); return; } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- - * - * Check that the WinSock was successfully initialized. - * - * Warning: - * This check was useful in times of Windows98 where WinSock may - * not be available. This is not the case any more. - * This function may be removed with TCL 9.0 - * - * Results: - * 1 if it is. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SocketsEnabled(void) -{ - int enabled; - - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} - - -/* - *---------------------------------------------------------------------- - * * SocketExitHandler -- * * Callback invoked during exit clean up to delete the socket @@ -3454,9 +3322,7 @@ TcpThreadActionProc( * sockets will not work. */ - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TclInitSockets(); tsdPtr = TCL_TSD_INIT(&dataKey); -- cgit v0.12 From aed83779fd0befd6315d01433e60ba27a324fc31 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:35:41 +0000 Subject: tests/httpProxy.test - test for leftover socket placeholders, improve result layout, for https fetch with status 407 expect result SecureProxyFailed not SecureProxy. --- tests/httpProxy.test | 236 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 144 insertions(+), 92 deletions(-) diff --git a/tests/httpProxy.test b/tests/httpProxy.test index 90fe828..d9e865a 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -85,40 +85,44 @@ test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 noauth} -constraints {n } -body { set token [http::geturl http://$n4host:$n4port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$n6host\]:$n6port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://$a4host:$a4port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$a6host\]:$a6port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid} -setup { @@ -126,10 +130,12 @@ test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { @@ -137,10 +143,12 @@ test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSqui } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { @@ -148,10 +156,12 @@ test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {nee } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 HttpProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } @@ -160,34 +170,40 @@ test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {ne } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 SecureProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { - http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 HttpProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 SecureProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } @@ -198,10 +214,12 @@ test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} - set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -212,10 +230,12 @@ test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -226,10 +246,12 @@ test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-prov set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -240,38 +262,44 @@ test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-pro set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -282,10 +310,12 @@ test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -con set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -296,10 +326,12 @@ test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -co set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -310,10 +342,12 @@ test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provide set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -324,38 +358,44 @@ test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provid set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -366,10 +406,12 @@ test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -co set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -380,10 +422,12 @@ test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -c set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -394,10 +438,12 @@ test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provid set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -408,38 +454,44 @@ test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provi set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -- cgit v0.12 From bf454b34d59371152ca527105f0908a4d29027f1 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:40:55 +0000 Subject: tests/httpProxy.test - add new tests for cleanup (mainly after 407 request) by checking that a second request is handled correctly. --- tests/httpProxy.test | 638 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 638 insertions(+) diff --git a/tests/httpProxy.test b/tests/httpProxy.test index d9e865a..d8bd6b7 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -26,6 +26,10 @@ proc bgerror {args} { puts stderr $errorInfo } +proc stopMe {token} { + set ${token}(z) done +} + if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} @@ -303,6 +307,294 @@ test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-pro http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-3.7.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.7x.$ThreadLevel {http with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8x.$ThreadLevel {https with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9p.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9x.$ThreadLevel {http with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10p.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10x.$ThreadLevel {https with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { @@ -399,6 +691,179 @@ test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provid http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-4.7.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.8.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9p.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10p.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { @@ -495,10 +960,183 @@ test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provi http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-5.7.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.7p.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # Use the same caution as for the corresponding https test. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8p.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.9.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.10.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + # cleanup unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds rename bgerror {} +rename stopMe {} ::tcltest::cleanupTests -- cgit v0.12 From 4c3d010bffd99f30596787903dfa04162f26c2b3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:44:39 +0000 Subject: library/http/http.tcl - replace lremove with lreplace for compatibility with 8.6. --- library/http/http.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index fcb03e1..bbde39d 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -4896,7 +4896,7 @@ proc http::SecureProxyConnect {args} { # Extract (non-proxy) target from args. set host [lindex $args end-3] set port [lindex $args end-2] - set args [lremove $args end-3 end-2] + set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. -- cgit v0.12 From 95b74de5c21547a344748baff089d47e8c57e391 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:49:08 +0000 Subject: library/http/http.tcl - in http::SecureProxyConnect and its caller, bugfix cleanup after 407 from HTTPS proxy. Close the connection to the proxy. Do not copy all values of state() from the proxy CONNECT to the main request, especially leave out state(sock). Raise an error for a 3xx and 401 response to CONNECT. In http::Event, trap TLS handshake errors in a place where they do not occur for a non-proxy request. --- library/http/http.tcl | 176 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 132 insertions(+), 44 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index bbde39d..907256e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -219,6 +219,33 @@ namespace eval http { 511 {Network Authentication Required} }] + variable failedProxyValues { + binary + body + charset + coding + connection + connectionRespFlag + currentsize + host + http + httpResponse + meta + method + querylength + queryoffset + reasonPhrase + requestHeaders + requestLine + responseCode + state + status + tid + totalsize + transfer + type + } + namespace export geturl config reset wait formatQuery postError quoteString namespace export register unregister registerError namespace export requestLine requestHeaders requestHeaderValue @@ -871,6 +898,7 @@ proc http::reset {token {why reset}} { set errorlist $state(error) unset state eval ::error $errorlist + # i.e. error msg errorInfo errorCode } return } @@ -1699,14 +1727,21 @@ proc http::OpenSocket {token DoLater} { ConfigureNewSocket $token $sockOld $DoLater } result errdict]} { if {[string range $result 0 20] eq {proxy connect failed:}} { - # The socket can be persistent: if so it is identified with - # the https target host, and will be kept open. - # Results of the failed proxy CONNECT have been copied to $token and - # are available to the caller. - Eot $token - } else { - Finish $token $result - } + # - The HTTPS proxy did not create a socket. The pre-existing value + # (a "placeholder socket") is unchanged. + # - The proxy returned a valid HTTP response to the failed CONNECT + # request, and http::SecureProxyConnect copied this to $token, + # and also set ${token}(connection) set to "close". + # - Remove the error message $result so that Finish delivers this + # HTTP response to the caller. + set result {} + } + Finish $token $result + # Because socket creation failed, the placeholder "socket" must be + # "closed" and (if persistent) removed from the persistent sockets + # table. In the {proxy connect failed:} case Finish does this because + # the value of ${token}(connection) is "close". In the other cases here, + # it does so because $result is non-empty. } ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token return @@ -2325,7 +2360,8 @@ proc http::Connected {token proto phost srvurl} { # If any other requests are in flight or pipelined/queued, they will # be discarded. } elseif {$state(status) eq ""} { - # ...https handshake errors come here. + # https handshake errors come here, for + # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. set msg [registerError $sock] registerError $sock {} if {$msg eq {}} { @@ -3473,8 +3509,15 @@ proc http::Event {sock token} { # If any other requests are in flight or pipelined/queued, # they will be discarded. } else { + # https handshake errors come here, for + # Tcl 8.7 with http::SecureProxyConnect. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg $nsl + } Log ^X$tk end of response (error) - token $token - Finish $token $nsl + Finish $token $msg return } } elseif {$nsl >= 0} { @@ -4882,15 +4925,12 @@ proc http::socketForTls {args} { # # Return Value: a socket identifier # ------------------------------------------------------------------------------ -proc http::AllDone {varName args} { - set $varName done - return -} proc http::SecureProxyConnect {args} { variable http variable ConnectVar variable ConnectCounter + variable failedProxyValues set varName ::http::ConnectVar([incr ConnectCounter]) # Extract (non-proxy) target from args. @@ -4941,8 +4981,11 @@ proc http::SecureProxyConnect {args} { variable $token2 upvar 0 $token2 state2 - # Setting this variable overrides the HTTP request line and allows + # Kludges: + # Setting this variable overrides the HTTP request line and also allows # -headers to override the Connection: header set by -keepalive. + # The arguments "-keepalive 0" ensure that when Finish is called for an + # unsuccessful request, the socket is always closed. set state2(bypass) "CONNECT $host:$port HTTP/1.1" AsyncTransaction $token2 @@ -4961,41 +5004,86 @@ proc http::SecureProxyConnect {args} { } unset $varName - set sock $state2(sock) - set code $state2(responseCode) - if {[string is integer -strict $code] && ($code >= 200) && ($code < 300)} { - # All OK. The caller in tls will now call "tls::import $sock". - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 - } elseif {$targ != -1} { - # Bad HTTP status code; token is known. - # Copy from state2 to state, including (sock). - foreach name [array names state2] { - set state($name) $state2($name) + if { ($state2(state) ne "complete") + || ($state2(status) ne "ok") + || (![string is integer -strict $state2(responseCode)]) + } { + set msg {the HTTP request to the proxy server did not return a valid\ + and complete response} + if {[info exists state2(error)]} { + append msg ": " [lindex $state2(error) 0] } - set state(proxyUsed) SecureProxy - set state(proxyFail) failed + cleanup $token2 + return -code error $msg + } - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 + set code $state2(responseCode) - # Error message detected by http::OpenSocket. - return -code error "proxy connect failed: $code" - } else { - # Bad HTTP status code; token is not known because option -type - # (cf. targ) was not passed through tcltls, and so the script - # cannot write to state(*). - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 + if {($code >= 200) && ($code < 300)} { + # All OK. The caller in package tls will now call "tls::import $sock". + # The cleanup command does not close $sock. + # Other tidying was done in http::Event. + set sock $state2(sock) + cleanup $token2 + return $sock + } - # Error message detected by http::OpenSocket. - return -code error "proxy connect failed: $code\n$block" + if {$targ != -1} { + # Non-OK HTTP status code; token is known because option -type + # (cf. targ) was passed through tcltls, and so the useful + # parts of the proxy's response can be copied to state(*). + # Do not copy state2(sock). + # Return the proxy response to the caller of geturl. + foreach name $failedProxyValues { + if {[info exists state2($name)]} { + set state($name) $state2($name) + } + } + set state(proxyUsed) SecureProxyFailed + set state(connection) close + set msg "proxy connect failed: $code" + # - This error message will be detected by http::OpenSocket and will + # cause it to present the proxy's HTTP response as that of the + # original $token transaction, identified only by state(proxyUsed) + # as the response of the proxy. + # - The cases where this would mislead the caller of http::geturl are + # given a different value of msg (below) so that http::OpenSocket will + # treat them as errors, but will preserve the $token array for + # inspection by the caller. + # - Status code 305 (Proxy Required) was deprecated for security reasons + # in RFC 2616 (June 1999) and in any case should never be served by a + # proxy. + # - Other 3xx responses from the proxy are inappropriate, and should not + # occur. + # - A 401 response from the proxy is inappropriate, and should not + # occur. It would be confusing if returned to the caller. + + if {($code >= 300) && ($code < 400)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate $code redirect" + set loc [responseHeaderValue $token2 location] + if {$loc ne {}} { + append msg "to " $loc + } + } elseif {($code == 401)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate 401 request for target-host credentials" + } else { + } + } else { + set msg "connection to proxy failed with status code $code" } - return $sock + # - ${token2}(sock) has already been closed because -keepalive 0. + # - Error return does not pass the socket ID to the + # $token transaction, which retains its socket placeholder. + cleanup $token2 + return -code error $msg +} + +proc http::AllDone {varName args} { + set $varName done + return } -- cgit v0.12 From 0a9238b48a692d42d47391c88a59e76e3c3d8a52 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:53:19 +0000 Subject: library/http/http.tcl - in http::SecureProxyConnect, bugfix state(proxyUsed) so the correct value SecureProxyFailed or SecureProxy is returned. --- library/http/http.tcl | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 907256e..0ba201e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -805,7 +805,7 @@ proc http::CloseQueuedQueries {connId {token {}}} { variable socketPlayCmd variable socketCoEvent - ##Log CloseQueuedQueries $connId + ##Log CloseQueuedQueries $connId $token if {![info exists socketMapping($connId)]} { # Command has already been called. # Don't come here again - especially recursively. @@ -1725,7 +1725,9 @@ proc http::OpenSocket {token DoLater} { # Code above has set state(sock) $sock ConfigureNewSocket $token $sockOld $DoLater + ##Log OpenSocket success $sock - token $token } result errdict]} { + ##Log OpenSocket failed $result - token $token if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. @@ -4958,8 +4960,12 @@ proc http::SecureProxyConnect {args} { # Record in the token that this is a proxy call. set token [lindex $args $targ+1] upvar 0 ${token} state - set state(proxyUsed) SecureProxy set tim $state(-timeout) + set state(proxyUsed) SecureProxyFailed + # This value is overwritten with "SecureProxy" below if the CONNECT is + # successful. If it is unsuccessful, the socket will be closed + # below, and so in this unsuccessful case there are no other transactions + # whose (proxyUsed) must be updated. } else { set tim 0 } @@ -5023,6 +5029,11 @@ proc http::SecureProxyConnect {args} { # All OK. The caller in package tls will now call "tls::import $sock". # The cleanup command does not close $sock. # Other tidying was done in http::Event. + + # If this is a persistent socket, any other transactions that are + # already marked to use the socket will have their (proxyUsed) updated + # when http::OpenSocket calls http::ConfigureNewSocket. + set state(proxyUsed) SecureProxy set sock $state2(sock) cleanup $token2 return $sock @@ -5039,7 +5050,6 @@ proc http::SecureProxyConnect {args} { set state($name) $state2($name) } } - set state(proxyUsed) SecureProxyFailed set state(connection) close set msg "proxy connect failed: $code" # - This error message will be detected by http::OpenSocket and will -- cgit v0.12 From c3e9fc9aedad22f58fd1fe766f6d01ccb8d3d6f7 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 22:02:33 +0000 Subject: library/http/http.tcl - define http::socketProxyId and use it to record the proxy (if any) used by each persistent socket. Minor fix to socketPhQueue. --- library/http/http.tcl | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 0ba201e..f1d5f8b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -77,6 +77,7 @@ namespace eval http { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[info exists socketMapping]} { # Close open sockets on re-init. Do not permit retries. foreach {url sock} [array get socketMapping] { @@ -101,6 +102,7 @@ namespace eval http { array unset socketClosing array unset socketPlayCmd array unset socketCoEvent + array unset socketProxyId array set socketMapping {} array set socketRdState {} array set socketWrState {} @@ -110,6 +112,7 @@ namespace eval http { array set socketClosing {} array set socketPlayCmd {} array set socketCoEvent {} + array set socketProxyId {} return } init @@ -407,6 +410,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -540,6 +544,7 @@ proc http::KeepSocket {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -742,6 +747,7 @@ proc http::CloseSocket {s {token {}}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set tk [namespace tail $token] @@ -804,6 +810,7 @@ proc http::CloseQueuedQueries {connId {token {}}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId ##Log CloseQueuedQueries $connId $token if {![info exists socketMapping($connId)]} { @@ -865,6 +872,7 @@ proc http::Unset {connId} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId unset socketMapping($connId) unset socketRdState($connId) @@ -873,6 +881,7 @@ proc http::Unset {connId} { unset -nocomplain socketWrQueue($connId) unset -nocomplain socketClosing($connId) unset -nocomplain socketPlayCmd($connId) + unset -nocomplain socketProxyId($connId) return } @@ -1344,6 +1353,11 @@ proc http::CreateToken {url args} { set srvurl $url set targetAddr [list $phost $pport] set state(proxyUsed) HttpProxy + # The value of state(proxyUsed) none|HttpProxy depends only on the + # all-transactions http::config settings and on the target URL. + # Even if this is a persistent socket there is no need to change the + # value of state(proxyUsed) for other transactions that use the socket: + # they have the same value already. } else { set targetAddr [list $host $port] } @@ -1379,6 +1393,7 @@ proc http::CreateToken {url args} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[info exists socketMapping($state(socketinfo))]} { # - If the connection is idle, it has a "fileevent readable" binding @@ -1401,6 +1416,7 @@ proc http::CreateToken {url args} { # causes a call to Finish. set reusing 1 set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) Log "reusing closing socket $sock for $state(socketinfo) - token $token" set state(alreadyQueued) 1 @@ -1435,6 +1451,7 @@ proc http::CreateToken {url args} { # - The socket may not yet exist, and be defined with a placeholder. set reusing 1 set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) if {[SockIsPlaceHolder $sock]} { set state(ReusingPlaceholder) 1 lappend socketPhQueue($sock) $token @@ -1533,6 +1550,7 @@ proc http::AsyncTransaction {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set sock $state(sock) @@ -1609,9 +1627,15 @@ proc http::PreparePersistentConnection {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set DoLater {-traceread 0 -tracewrite 0} set socketMapping($state(socketinfo)) $state(sock) + set socketProxyId($state(socketinfo)) $state(proxyUsed) + # - The value of state(proxyUsed) was set in http::CreateToken to either + # "none" or "HttpProxy". + # - $token is the first transaction to use this placeholder, so there are + # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { set socketRdState($state(socketinfo)) {} @@ -1643,10 +1667,11 @@ proc http::PreparePersistentConnection {token} { set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} - set socketPhQueue($state(socketinfo)) {} + set socketPhQueue($state(sock)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} + set socketProxyId($state(socketinfo)) {} return $DoLater } @@ -1679,6 +1704,7 @@ proc http::OpenSocket {token DoLater} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId Log >K$tk Start OpenSocket coroutine @@ -1795,9 +1821,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set reusing $state(reusing) set sock $state(sock) + set proxyUsed $state(proxyUsed) ##Log " ConfigureNewSocket" $token $sockOld ... -- $sock if {(!$reusing) && ($sock ne $sockOld)} { @@ -1807,6 +1835,8 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { && ($socketMapping($state(socketinfo)) eq $sockOld) } { set socketMapping($state(socketinfo)) $sock + set socketProxyId($state(socketinfo)) $proxyUsed + # tokens that use the placeholder $sockOld are updated below. ##Log set socketMapping($state(socketinfo)) $sock } @@ -1846,6 +1876,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # 1. Amend the token's (sock). ##Log set ${tok}(sock) $sock set ${tok}(sock) $sock + set ${tok}(proxyUsed) $proxyUsed # 2. Schedule the token's HTTP request. # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. @@ -1876,7 +1907,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # waiting until the read(s) in progress are finished). # socketRdQueue($connId) List of tokens that are queued for reading later. # socketWrQueue($connId) List of tokens that are queued for writing later. -# socketPhQueue($connId) List of tokens that are queued to use a placeholder +# socketPhQueue($sock) List of tokens that are queued to use a placeholder # socket, when the real socket has not yet been created. # socketClosing($connId) (boolean) true iff a server response header indicates # that the server will close the connection at the end of @@ -1885,6 +1916,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # part-completed transactions if the socket closes early. # socketCoEvent($connId) Identifier for the "after idle" event that will launch # an OpenSocket coroutine to open or re-use a socket. +# socketProxyId($connId) The type of proxy that this socket uses: values are +# those of state(proxyUsed) i.e. none, HttpProxy, +# SecureProxy, and SecureProxyFailed. +# The value is not used for anything by http, its purpose +# is to set the value of state() for caller information. # ------------------------------------------------------------------------------ @@ -1940,6 +1976,7 @@ proc http::ScheduleRequest {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set Unfinished 0 @@ -2085,6 +2122,7 @@ proc http::Connected {token proto phost srvurl} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2424,6 +2462,7 @@ proc http::DoneRequest {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2755,6 +2794,7 @@ proc http::ReplayIfDead {token doing} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2998,6 +3038,7 @@ proc http::ReplayCore {newQueue} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[llength $newQueue] == 0} { # Nothing to do. @@ -3347,6 +3388,7 @@ proc http::Write {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -3459,6 +3501,7 @@ proc http::Event {sock token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state -- cgit v0.12 From 03a9eaa9512a6a1a87cc4c3225caa6bbcb44cdb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 22:04:59 +0000 Subject: Use TCLFLEXARRAY --- generic/tclTrace.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 8999858..6749978 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -56,7 +56,7 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -1039,7 +1039,7 @@ TraceVariableObjCmd( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ @@ -1818,7 +1818,8 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i, saveInterpFlags; + int i; + int saveInterpFlags; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); @@ -2074,7 +2075,7 @@ TraceVarProc( /* *---------------------------------------------------------------------- * - * Tcl_CreateObjTrace -- + * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 -- * * Arrange for a function to be called to trace command execution. * @@ -2087,7 +2088,7 @@ TraceVarProc( * called to execute a Tcl command. Calls to proc will have the following * form: * - * void proc(ClientData clientData, + * void proc(void * clientData, * Tcl_Interp * interp, * int level, * const char * command, @@ -3036,7 +3037,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_VarTraceInfo2( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *part1, /* Name of variable or array. */ -- cgit v0.12 From e977d6e7af0d658006f243be34f927a266b0fc23 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 22:06:42 +0000 Subject: library/http/http.tcl - bugfix OpenSocket to replay any requests in the socketPhQueue placeholder queue, if the socket was not created. --- library/http/http.tcl | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index f1d5f8b..4c9f6a7 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1753,7 +1753,20 @@ proc http::OpenSocket {token DoLater} { ConfigureNewSocket $token $sockOld $DoLater ##Log OpenSocket success $sock - token $token } result errdict]} { - ##Log OpenSocket failed $result - token $token + ##Log OpenSocket failed $result - token $token + # There may be other requests in the socketPhQueue. + # Prepare socketPlayCmd so that Finish will replay them. + if { ($state(-keepalive)) && (!$state(reusing)) + && [info exists socketPhQueue($sockOld)] + && ($socketPhQueue($sockOld) ne {}) + } { + if {$socketMapping($state(socketinfo)) ne $sockOld} { + Log "WARNING: this code should not be reached.\ + {$socketMapping($state(socketinfo)) ne $sockOld}" + } + set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] + set socketPhQueue($sockOld) {} + } if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. -- cgit v0.12 From 7e8c940ac114ea986ce22a24a142df025e0b1bbb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 07:28:44 +0000 Subject: Fix "package files tcl", considering TIP #590 --- generic/tclInterp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c5f84db..ad24d28 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -333,7 +333,7 @@ int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { - PkgName pkgName = {NULL, "Tcl"}; + PkgName pkgName = {NULL, "tcl"}; PkgName **names = (PkgName **)TclInitPkgFiles(interp); int result = TCL_ERROR; -- cgit v0.12 From 008001c3b5e35ff3c122f2eb1bf566d93746b172 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 07:30:42 +0000 Subject: More TCLFLEXARRAY usage --- generic/tclPkg.c | 2 +- generic/tclTrace.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index fd45cc1..bfe1c66 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -40,7 +40,7 @@ typedef struct PkgAvail { typedef struct PkgName { struct PkgName *nextPtr; /* Next in list of package names being * initialized. */ - char name[1]; + char name[TCLFLEXARRAY]; } PkgName; typedef struct PkgFiles { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 0c243a6..bed5084 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -22,7 +22,7 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NUL chars. in command. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -56,7 +56,7 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 -- cgit v0.12 From 2afe485f41e0c7303cbf8d181745c56f7d19f5b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 09:59:28 +0000 Subject: NEVER use sizeof(FLEXARRAY)! Use offsetof() --- generic/tclPkg.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index bfe1c66..7866158 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -828,7 +828,7 @@ SelectPackage( * Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = (PkgName *)ckalloc(sizeof(PkgName) + strlen(name)); + pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; -- cgit v0.12 From b6c0957a8f2f5b52b9c0f1c1c433cda524970f99 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 20:27:01 +0000 Subject: More int -> size_t (argc and level) in trace handling --- doc/CrtObjCmd.3 | 2 +- doc/CrtTrace.3 | 16 +++++++- generic/tcl.decls | 6 +-- generic/tcl.h | 4 +- generic/tclDecls.h | 18 +++++---- generic/tclInt.h | 6 ++- generic/tclTrace.c | 110 ++++++++++++++++++++++++++--------------------------- 7 files changed, 91 insertions(+), 71 deletions(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 012c46c..ffd9e27 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -224,7 +224,7 @@ pointed to by \fIinfoPtr\fR and returns 1. A \fBTcl_CmdInfo\fR structure has the following fields: .PP .CS -typedef struct Tcl_CmdInfo { +typedef struct { int \fIisNativeObjectProc\fR; Tcl_ObjCmdProc *\fIobjProc\fR; void *\fIobjClientData\fR; diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 6833fc5..e4d1a43 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -29,7 +29,7 @@ Tcl_Trace .AS Tcl_CmdObjTraceDeleteProc *deleteProc .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. -.AP int level in +.AP size_t level in Only commands at or below this nesting level will be traced unless 0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are @@ -81,6 +81,20 @@ typedef int \fBTcl_CmdObjTraceProc\fR( \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP +\fIobjProc2\fR should have arguments and result that match the type, +\fBTcl_CmdObjTraceProc2\fR: +.PP +.CS +typedef int \fBTcl_CmdObjTraceProc2\fR( + \fBvoid *\fR \fIclientData\fR, + \fBTcl_Interp\fR* \fIinterp\fR, + size_t \fIlevel\fR, + const char *\fIcommand\fR, + \fBTcl_Command\fR \fIcommandToken\fR, + size_t \fIobjc\fR, + \fBTcl_Obj\fR *const \fIobjv\fR[]); +.CE +.PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. \fIclientData\fR typically points to an application-specific data diff --git a/generic/tcl.decls b/generic/tcl.decls index 0def57e..322d0cf 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -388,7 +388,7 @@ declare 98 { Tcl_TimerProc *proc, void *clientData) } declare 99 { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData) } declare 100 { @@ -1781,7 +1781,7 @@ declare 482 { # TIP#32 (object-enabled traces) kbk declare 483 { - Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } @@ -2576,7 +2576,7 @@ declare 676 { Tcl_CmdDeleteProc *deleteProc) } declare 677 { - Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } diff --git a/generic/tcl.h b/generic/tcl.h index 706c5f1..a2fd2a4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -558,7 +558,7 @@ typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - int level, const char *command, Tcl_Command commandInfo, size_t objc, + size_t level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, @@ -773,7 +773,7 @@ typedef struct Tcl_CallFrame { * then calls the other function. */ -typedef struct Tcl_CmdInfo { +typedef struct { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8040adf..8e4aa59 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -306,7 +306,7 @@ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ -EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, +EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, @@ -1263,8 +1263,9 @@ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc *objProc, +EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ @@ -1824,8 +1825,9 @@ EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 677 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc2 *objProc2, +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 678 */ @@ -1960,7 +1962,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ @@ -2344,7 +2346,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ @@ -2538,7 +2540,7 @@ typedef struct TclStubs { int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ - Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index a633a17..1b817e9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1041,9 +1041,13 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); */ typedef struct Trace { - int level; /* Only trace commands at nesting level less + Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ +#if TCL_MAJOR_VERSION > 8 + Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */ +#else Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ +#endif void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2c525b0..1b70f1e 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -44,7 +44,7 @@ typedef struct { size_t length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution + Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution @@ -99,7 +99,7 @@ enum traceOptions { #endif }; typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptions optionIndex, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; static Tcl_TraceTypeObjCmd TraceCommandObjCmd; @@ -126,18 +126,18 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, size_t numChars, - int objc, Tcl_Obj *const objv[]); + Command *cmdPtr, const char *command, Tcl_Size numChars, + Tcl_Size objc, Tcl_Obj *const objv[]); static char * TraceVarProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static Tcl_CmdObjTraceProc TraceExecutionProc; +static Tcl_CmdObjTraceProc2 TraceExecutionProc; static int StringTraceProc(void *clientData, - Tcl_Interp *interp, int level, + Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); static void StringTraceDeleteProc(void *clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, @@ -270,7 +270,7 @@ Tcl_TraceObjCmd( Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; int code; - size_t numFlags; + Tcl_Size numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); @@ -399,11 +399,11 @@ static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; @@ -416,7 +416,7 @@ TraceExecutionObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -461,8 +461,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -571,7 +570,7 @@ TraceExecutionObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - size_t numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -647,11 +646,11 @@ static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index; @@ -659,7 +658,7 @@ TraceCommandObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -700,8 +699,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -776,7 +774,7 @@ TraceCommandObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - size_t numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -843,11 +841,11 @@ static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; void *clientData; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL @@ -860,7 +858,7 @@ TraceVariableObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -905,8 +903,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) @@ -1423,17 +1420,17 @@ TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - TCL_UNUSED(size_t) /*numChars*/, + TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - size_t objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1528,18 +1525,18 @@ TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - size_t numChars, /* The number of characters in 'command' which + Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - size_t objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1675,9 +1672,9 @@ CallTraceFunction( Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ - size_t numChars, /* The number of characters in the command's + Tcl_Size numChars, /* The number of characters in the command's * source. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1760,10 +1757,10 @@ static int TraceExecutionProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, TCL_UNUSED(Tcl_Command), - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { int call = 0; @@ -1818,7 +1815,7 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i; + Tcl_Size i; int saveInterpFlags; Tcl_DStringInit(&cmd); @@ -1926,7 +1923,7 @@ TraceExecutionProc( tcmdPtr->startCmd = (char *)Tcl_Alloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + tcmdPtr->stepTrace = Tcl_CreateObjTrace2(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } @@ -2128,7 +2125,7 @@ TraceVarProc( */ typedef struct { - Tcl_CmdObjTraceProc2 *proc; + Tcl_CmdObjTraceProc *proc; Tcl_CmdObjTraceDeleteProc *delProc; void *clientData; } TraceWrapperInfo; @@ -2136,14 +2133,17 @@ typedef struct { static int traceWrapperProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; - return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv); + if (objc > INT_MAX) { + objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ + } + return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv); } static void traceWrapperDelProc(void *clientData) @@ -2157,30 +2157,30 @@ static void traceWrapperDelProc(void *clientData) } Tcl_Trace -Tcl_CreateObjTrace2( +Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ + Tcl_CmdObjTraceProc *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); + TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); info->proc = proc; info->delProc = delProc; info->clientData = clientData; - return Tcl_CreateObjTrace(interp, level, flags, + return Tcl_CreateObjTrace2(interp, level, flags, (proc ? traceWrapperProc : NULL), info, traceWrapperDelProc); } Tcl_Trace -Tcl_CreateObjTrace( +Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc *proc, /* Trace callback */ + Tcl_CmdObjTraceProc2 *proc2, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ @@ -2212,7 +2212,7 @@ Tcl_CreateObjTrace( tracePtr = (Trace *)Tcl_Alloc(sizeof(Trace)); tracePtr->level = level; - tracePtr->proc = proc; + tracePtr->proc = proc2; tracePtr->clientData = clientData; tracePtr->delProc = delProc; tracePtr->nextPtr = iPtr->tracePtr; @@ -2267,7 +2267,7 @@ Tcl_CreateObjTrace( Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ - int level, /* Only call proc for commands at nesting + Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ @@ -2277,7 +2277,7 @@ Tcl_CreateTrace( data->clientData = clientData; data->proc = proc; - return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, + return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); } @@ -2301,16 +2301,16 @@ static int StringTraceProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const *objv) { StringTraceData *data = (StringTraceData *)clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ - int i; + Tcl_Size i; /* * This is a bit messy because we have to emulate the old trace interface, -- cgit v0.12 From a90bc45a547c857ffc5257490827aebfb7ac6d8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 21:58:01 +0000 Subject: int -> size_t in Tcl_CmdObjTraceProc2 (for 'level'). Add missing documentation --- doc/CrtTrace.3 | 24 ++++-- generic/tcl.decls | 6 +- generic/tcl.h | 2 +- generic/tclDecls.h | 18 +++-- generic/tclInt.h | 2 +- generic/tclTrace.c | 230 +++++++++++++++++++++++++++-------------------------- 6 files changed, 153 insertions(+), 129 deletions(-) diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 417c892..723a392 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -47,7 +47,7 @@ details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIobjProc\fR, \fIobjProc2\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of @@ -72,7 +72,7 @@ interpreter. .PP .CS typedef int \fBTcl_CmdObjTraceProc\fR( - \fBClientData\fR \fIclientData\fR, + \fBvoid *\fR \fIclientData\fR, \fBTcl_Interp\fR* \fIinterp\fR, int \fIlevel\fR, const char *\fIcommand\fR, @@ -81,6 +81,20 @@ typedef int \fBTcl_CmdObjTraceProc\fR( \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP +\fIobjProc2\fR should have arguments and result that match the type, +\fBTcl_CmdObjTraceProc2\fR: +.PP +.CS +typedef int \fBTcl_CmdObjTraceProc2\fR( + \fBvoid *\fR \fIclientData\fR, + \fBTcl_Interp\fR* \fIinterp\fR, + size_t \fIlevel\fR, + const char *\fIcommand\fR, + \fBTcl_Command\fR \fIcommandToken\fR, + size_t \fIobjc\fR, + \fBTcl_Obj\fR *const \fIobjv\fR[]); +.CE +.PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. \fIClientData\fR typically points to an application-specific data @@ -146,7 +160,7 @@ When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the .PP .CS typedef void \fBTcl_CmdObjTraceDeleteProc\fR( - \fBClientData\fR \fIclientData\fR); + \fBvoid *\fR \fIclientData\fR); .CE .PP The \fIclientData\fR parameter will be the same as the @@ -162,12 +176,12 @@ match the type \fBTcl_CmdTraceProc\fR: .PP .CS typedef void \fBTcl_CmdTraceProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, - ClientData \fIcmdClientData\fR, + void *\fIcmdClientData\fR, int \fIargc\fR, const char *\fIargv\fR[]); .CE diff --git a/generic/tcl.decls b/generic/tcl.decls index 994af13..6d9fbbd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -374,7 +374,7 @@ declare 98 { Tcl_TimerProc *proc, void *clientData) } declare 99 { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData) } declare 100 { @@ -1722,7 +1722,7 @@ declare 482 { # TIP#32 (object-enabled traces) kbk declare 483 { - Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } @@ -2517,7 +2517,7 @@ declare 676 { Tcl_CmdDeleteProc *deleteProc) } declare 677 { - Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } diff --git a/generic/tcl.h b/generic/tcl.h index 3560481..e705cdb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -674,7 +674,7 @@ typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - int level, const char *command, Tcl_Command commandInfo, size_t objc, + size_t level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8cb77b8..0888ecf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -360,7 +360,7 @@ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ -EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, +EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, @@ -1451,8 +1451,9 @@ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc *objProc, +EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ @@ -2012,8 +2013,9 @@ EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 677 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc2 *objProc2, +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 678 */ @@ -2164,7 +2166,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ @@ -2556,7 +2558,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ @@ -2750,7 +2752,7 @@ typedef struct TclStubs { int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ - Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index bdd7e5a..ec82abd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1019,7 +1019,7 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); */ typedef struct Trace { - int level; /* Only trace commands at nesting level less + Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ void *clientData; /* Arbitrary value to pass to proc. */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index bed5084..e2be167 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -21,7 +21,7 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NUL chars. in command. */ + Tcl_Size length; /* Number of non-NUL chars. in command. */ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the @@ -41,10 +41,10 @@ typedef struct { typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NUL chars. in command. */ + Tcl_Size length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution + Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution @@ -92,8 +92,15 @@ typedef struct { * Forward declarations for functions defined in this file: */ -typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, - int objc, Tcl_Obj *const objv[]); +/* 'OLD' options are pre-Tcl-8.4 style */ +enum traceOptionsEnum { + TRACE_ADD, TRACE_INFO, TRACE_REMOVE +#ifndef TCL_REMOVE_OBSOLETE_TRACES + ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO +#endif +}; +typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex, + Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; static Tcl_TraceTypeObjCmd TraceCommandObjCmd; @@ -120,19 +127,19 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, int numChars, - int objc, Tcl_Obj *const objv[]); -static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, + Command *cmdPtr, const char *command, Tcl_Size numChars, + Tcl_Size objc, Tcl_Obj *const objv[]); +static char * TraceVarProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); -static void TraceCommandProc(ClientData clientData, +static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static Tcl_CmdObjTraceProc TraceExecutionProc; -static int StringTraceProc(ClientData clientData, - Tcl_Interp *interp, int level, +static int StringTraceProc(void *clientData, + Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, Tcl_Obj *const objv[]); -static void StringTraceDeleteProc(ClientData clientData); + Tcl_Size objc, Tcl_Obj *const objv[]); +static void StringTraceDeleteProc(void *clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, const char *part2, VarTrace *tracePtr); @@ -143,7 +150,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, */ typedef struct { - ClientData clientData; /* Client data from Tcl_CreateTrace */ + void *clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -185,10 +192,9 @@ int Tcl_TraceObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; #ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; @@ -201,13 +207,7 @@ Tcl_TraceObjCmd( #endif NULL }; - /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptionsEnum { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, -#ifndef TCL_REMOVE_OBSOLETE_TRACES - TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO -#endif - }; + int optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -237,7 +237,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); } case TRACE_INFO: { /* @@ -260,7 +260,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); break; } @@ -312,7 +312,7 @@ Tcl_TraceObjCmd( return code; } case TRACE_OLD_VINFO: { - ClientData clientData; + void *clientData; char ops[5]; Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; @@ -397,16 +397,12 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE - }; + Tcl_Size length; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; @@ -414,12 +410,13 @@ TraceExecutionObjCmd( TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; + int index; - switch ((enum traceOptions) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -464,9 +461,8 @@ TraceExecutionObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -495,7 +491,7 @@ TraceExecutionObjCmd( * first one that matches. */ - ClientData clientData; + void *clientData; /* * First ensure the name given is valid. @@ -519,7 +515,7 @@ TraceExecutionObjCmd( && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { @@ -554,7 +550,7 @@ TraceExecutionObjCmd( break; } case TRACE_INFO: { - ClientData clientData; + void *clientData; Tcl_Obj *resultListPtr; if (objc != 4) { @@ -574,7 +570,7 @@ TraceExecutionObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - int numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -619,6 +615,10 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -645,22 +645,21 @@ TraceExecutionObjCmd( static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + int index; - switch ((enum traceOptions) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -701,9 +700,8 @@ TraceCommandObjCmd( } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -728,7 +726,7 @@ TraceCommandObjCmd( * first one that matches. */ - ClientData clientData; + void *clientData; /* * First ensure the name given is valid. @@ -744,7 +742,7 @@ TraceCommandObjCmd( if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; @@ -758,7 +756,7 @@ TraceCommandObjCmd( break; } case TRACE_INFO: { - ClientData clientData; + void *clientData; Tcl_Obj *resultListPtr; if (objc != 4) { @@ -777,7 +775,7 @@ TraceCommandObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - int numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -813,6 +811,10 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -839,27 +841,26 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - ClientData clientData; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + Tcl_Size length; + void *clientData; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE }; + int index; - switch ((enum traceOptions) optionIndex) { + switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -904,9 +905,8 @@ TraceVariableObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); @@ -947,7 +947,7 @@ TraceVariableObjCmd( #endif )==flags) && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); @@ -1005,6 +1005,10 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -1034,13 +1038,13 @@ TraceVariableObjCmd( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ TCL_UNUSED(int) /*flags*/, Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ - ClientData prevClientData) /* If non-NULL, gives last value returned by + void *prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ @@ -1108,7 +1112,7 @@ Tcl_TraceCommand( * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; CommandTrace *tracePtr; @@ -1172,7 +1176,7 @@ Tcl_UntraceCommand( * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { CommandTrace *tracePtr; CommandTrace *prevPtr; @@ -1277,7 +1281,7 @@ Tcl_UntraceCommand( static void TraceCommandProc( - ClientData clientData, /* Information about the command trace. */ + void *clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ const char *oldName, /* Name of command being changed. */ const char *newName, /* New name of command. Empty string or NULL @@ -1300,7 +1304,7 @@ TraceCommandProc( */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { @@ -1418,17 +1422,17 @@ TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - TCL_UNUSED(int) /*numChars*/, + TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1523,18 +1527,18 @@ TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - int numChars, /* The number of characters in 'command' which + Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1670,9 +1674,9 @@ CallTraceFunction( Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ - int numChars, /* The number of characters in the command's + Tcl_Size numChars, /* The number of characters in the command's * source. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1717,7 +1721,7 @@ CallTraceFunction( static void CommandObjTraceDeleted( - ClientData clientData) + void *clientData) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -1753,12 +1757,12 @@ CommandObjTraceDeleted( static int TraceExecutionProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, TCL_UNUSED(Tcl_Command), - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { int call = 0; @@ -1813,10 +1817,11 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i, saveInterpFlags; + Tcl_Size i; + int saveInterpFlags; Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); /* * Append command with arguments. @@ -1960,7 +1965,7 @@ TraceExecutionProc( static char * TraceVarProc( - ClientData clientData, /* Information about the variable trace. */ + void *clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable or array. */ const char *name2, /* Name of element within array; NULL means @@ -1984,14 +1989,14 @@ TraceVarProc( result = NULL; if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { - if (tvarPtr->length != (size_t) 0) { + if (tvarPtr->length) { /* * Generate a command to execute by appending list elements for * the two variable names and the operation. */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES @@ -2069,7 +2074,7 @@ TraceVarProc( /* *---------------------------------------------------------------------- * - * Tcl_CreateObjTrace -- + * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 -- * * Arrange for a function to be called to trace command execution. * @@ -2082,7 +2087,7 @@ TraceVarProc( * called to execute a Tcl command. Calls to proc will have the following * form: * - * void proc(ClientData clientData, + * void proc(void * clientData, * Tcl_Interp * interp, * int level, * const char * command, @@ -2130,13 +2135,16 @@ typedef struct { static int traceWrapperProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ + } return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv); } @@ -2153,7 +2161,7 @@ static void traceWrapperDelProc(void *clientData) Tcl_Trace Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ @@ -2172,10 +2180,10 @@ Tcl_CreateObjTrace2( Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc *proc, /* Trace callback */ - ClientData clientData, /* Client data for the callback */ + void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { @@ -2235,12 +2243,12 @@ Tcl_CreateObjTrace( * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) - * ClientData clientData; + * void *clientData; * Tcl_Interp *interp; * int level; * char *command; * int (*cmdProc)(); - * ClientData cmdClientData; + * void *cmdClientData; * int argc; * char **argv; * { @@ -2261,11 +2269,11 @@ Tcl_CreateObjTrace( Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ - int level, /* Only call proc for commands at nesting + Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ - ClientData clientData) /* Arbitrary value word to pass to proc. */ + void *clientData) /* Arbitrary value word to pass to proc. */ { StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData)); @@ -2293,18 +2301,18 @@ Tcl_CreateTrace( static int StringTraceProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const *objv) { StringTraceData *data = (StringTraceData *)clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ - int i; + Tcl_Size i; /* * This is a bit messy because we have to emulate the old trace interface, @@ -2349,7 +2357,7 @@ StringTraceProc( static void StringTraceDeleteProc( - ClientData clientData) + void *clientData) { ckfree(clientData); } @@ -3239,7 +3247,7 @@ Tcl_TraceVar2( * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; int result; -- cgit v0.12 From 822d3017ef86babab61e2c2b44d6866e8d7f4349 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 9 Nov 2022 10:53:23 +0000 Subject: Bugfix to socketPhQueue. Add some Log commands for debugging. --- library/http/http.tcl | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 4c9f6a7..a1d4a2b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1665,9 +1665,12 @@ proc http::PreparePersistentConnection {token} { set socketWrState($state(socketinfo)) $token } + # Value of socketPhQueue() may have already been set by ReplayCore. + if {![info exists socketPhQueue($state(sock))]} { + set socketPhQueue($state(sock)) {} + } set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} - set socketPhQueue($state(sock)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} @@ -1839,7 +1842,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) - ##Log " ConfigureNewSocket" $token $sockOld ... -- $sock + ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { # Replace the placeholder value sockOld with sock. @@ -3071,6 +3074,7 @@ proc http::ReplayCore {newQueue} { if {![ReInit $token]} { Log FAILED in http::ReplayCore - NO tmp vars + Log ReplayCore reject $token Finish $token {cannot send this request again} return } @@ -3085,6 +3089,7 @@ proc http::ReplayCore {newQueue} { set state(reusing) 0 set state(ReusingPlaceholder) 0 set state(alreadyQueued) 0 + Log ReplayCore replay $token # Give the socket a placeholder name before it is created. set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] @@ -3097,7 +3102,9 @@ proc http::ReplayCore {newQueue} { set ${tok}(reusing) 1 set ${tok}(sock) $sock lappend socketPhQueue($sock) $tok + Log ReplayCore replay $tok } else { + Log ReplayCore reject $tok set ${tok}(reusing) 1 set ${tok}(sock) NONE Finish $tok {cannot send this request again} -- cgit v0.12 From 50f633ff289fe9ff3f3c37defa42209ecd4e24ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Nov 2022 17:15:52 +0000 Subject: No trailing ',' --- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 66acade..57adcf0 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,7 +42,7 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0, + TCL_OBJTYPE_V0 }; #define InstNameSetInternalRep(objPtr, inst) \ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 455d7a6..76a936c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -241,7 +241,7 @@ static const Tcl_ObjType encodingType = { DupEncodingInternalRep, NULL, NULL, - TCL_OBJTYPE_V0, + TCL_OBJTYPE_V0 }; #define EncodingSetInternalRep(objPtr, encoding) \ -- cgit v0.12 From 6065eb2868a1672cbc4285c8117db7cb451f239e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Nov 2022 11:20:02 +0000 Subject: Forgot one TCL_OBJTYPE_V0 --- macosx/tclMacOSXFCmd.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 020288f..71b98b5 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -88,7 +88,8 @@ static const Tcl_ObjType tclOSTypeType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfOSType, /* updateStringProc */ - SetOSTypeFromAny /* setFromAnyProc */ + SetOSTypeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; enum { -- cgit v0.12 From 874327229c5e64a52e1fc3b4da6a31936ec07ed2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Nov 2022 21:09:21 +0000 Subject: Add (internal) TclNewUIntObj(), and use it to fix TCL_LINK_WIDE_UINT for big (>= 2^63) integers. With testcase --- generic/tclInt.h | 35 +++++++++++++++++++++++++++++++++++ generic/tclLink.c | 11 +++++++---- generic/tclOOBasic.c | 2 +- tests/link.test | 4 ++-- 4 files changed, 45 insertions(+), 7 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index ec82abd..036c653 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4852,6 +4852,26 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) +#define TclNewUIntObj(objPtr, uw) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + Tcl_WideUInt uw_ = (uw); \ + if (uw_ > WIDE_MAX) { \ + mp_int bignumValue_; \ + if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \ + Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \ + } \ + TclSetBignumInternalRep((objPtr), &bignumValue_); \ + } else { \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ + (objPtr)->typePtr = &tclIntType; \ + } \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + #define TclNewIndexObj(objPtr, w) \ TclNewIntObj(objPtr, w) @@ -4880,6 +4900,21 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; #define TclNewIntObj(objPtr, w) \ (objPtr) = Tcl_NewWideIntObj(w) +#define TclNewUIntObj(objPtr, uw) \ + do { \ + Tcl_WideUInt uw_ = (uw); \ + if (uw_ > WIDE_MAX) { \ + mp_int bignumValue_; \ + if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + } else { \ + (objPtr) = NULL; \ + } \ + } else { \ + (objPtr) = Tcl_NewWideIntObj(uw_); \ + } \ + } while (0) + #define TclNewIndexObj(objPtr, w) \ TclNewIntObj(objPtr, w) diff --git a/generic/tclLink.c b/generic/tclLink.c index 0d57d44..af48302 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -553,7 +553,7 @@ GetUWide( */ return 1; } -#ifdef WORDS_BIGENDIAN +#ifndef WORDS_BIGENDIAN while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } @@ -1451,12 +1451,12 @@ ObjValue( } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); - case TCL_LINK_WIDE_UINT: + case TCL_LINK_WIDE_UINT: { if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], (Tcl_WideInt) + TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); @@ -1464,7 +1464,10 @@ ObjValue( return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + Tcl_Obj *uwObj; + TclNewUIntObj(uwObj, linkPtr->lastValue.uw); + return uwObj; + } case TCL_LINK_STRING: p = LinkedVar(char *); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6ea4681..3593193 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1249,7 +1249,7 @@ TclOOSelfObjCmd( } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); - TclNewIntObj(result[1], contextPtr->index); + TclNewIndexObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } diff --git a/tests/link.test b/tests/link.test index eba359c..69ebb02 100644 --- a/tests/link.test +++ b/tests/link.test @@ -69,9 +69,9 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup { set long 34543 set ulong 567890 set float 1.0987654321 - set uwide 357357357357 + set uwide 12345678901234567890 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 -6101065172474983726 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} test link-2.2 {writing bad values into variables} -setup { testlink delete } -constraints {testlink} -body { -- cgit v0.12 From 67e92c7ada3b079caeb029907f19ecce31906ff6 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 13 Nov 2022 06:06:43 +0000 Subject: Fix compilation error for STATS=memdbg --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index b079364..adf02b7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4880,7 +4880,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ - (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_); \ } else { \ (objPtr) = NULL; \ } \ -- cgit v0.12 From 7dc710b2f42b81cfac6a8e5b8a80f4acf35aee78 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 13 Nov 2022 06:37:55 +0000 Subject: Update Tcl_ObjType documentation --- doc/ObjectType.3 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 9f8d04f..3e6d0c2 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -109,6 +109,7 @@ typedef struct Tcl_ObjType { Tcl_DupInternalRepProc *\fIdupIntRepProc\fR; Tcl_UpdateStringProc *\fIupdateStringProc\fR; Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR; + size_t \fIversion\fR; } \fBTcl_ObjType\fR; .CE .SS "THE NAME FIELD" @@ -253,6 +254,10 @@ Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. +.SS "THE VERSION FIELD" +.PP +The \fIversion\fR member provides for future extensibility of the structure +and should be set to \fITCL_OBJTYPE_V0\fR. .SH "REFERENCE COUNT MANAGEMENT" .PP The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared -- cgit v0.12 From 46a5d4b5fa40f76f18980d1995c96698335ad4b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Nov 2022 16:53:43 +0000 Subject: Fix compilation error for STATS=memdbg. Fix incorrect comment --- generic/tclInt.h | 2 +- generic/tclLink.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 036c653..2d29e1d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4906,7 +4906,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ - (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_); \ } else { \ (objPtr) = NULL; \ } \ diff --git a/generic/tclLink.c b/generic/tclLink.c index af48302..1973067 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -557,9 +557,9 @@ GetUWide( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } -#else /* !WORDS_BIGENDIAN */ +#else /* WORDS_BIGENDIAN */ /* - * Little-endian can read the value directly. + * Big-endian can read the value directly. */ value = scratch.value; #endif /* WORDS_BIGENDIAN */ -- cgit v0.12 From 14225bf18403da5689ee38fe70343b877b7bc571 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Nov 2022 21:25:31 +0000 Subject: fix filename --- library/cookiejar/idna.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/cookiejar/idna.tcl b/library/cookiejar/idna.tcl index 658dcd6..dc25cd8 100644 --- a/library/cookiejar/idna.tcl +++ b/library/cookiejar/idna.tcl @@ -1,4 +1,4 @@ -# cookiejar.tcl -- +# idna.tcl -- # # Implementation of IDNA (Internationalized Domain Names for # Applications) encoding/decoding system, built on a punycode engine -- cgit v0.12 From 79f559fdb5b42afb0b51a81227aea6038d338b15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 10:57:59 +0000 Subject: Add mp_pack to the libtommath stub-table: it's easier to work with than mp_to_ubin --- generic/tclLink.c | 19 ++----------------- generic/tclStubInit.c | 6 ++++-- generic/tclTomMath.decls | 7 +++++++ generic/tclTomMathDecls.h | 22 ++++++++++++++++------ unix/Makefile.in | 12 +++++++++--- win/Makefile.in | 2 ++ win/makefile.vc | 2 ++ 7 files changed, 42 insertions(+), 28 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 1973067..397c9bc 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -537,15 +537,10 @@ GetUWide( } else if (type == TCL_NUMBER_BIG) { mp_int *numPtr = (mp_int *)clientData; Tcl_WideUInt value = 0; - union { - Tcl_WideUInt value; - unsigned char bytes[sizeof(Tcl_WideUInt)]; - } scratch; size_t numBytes; - unsigned char *bytes = scratch.bytes; - if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr, - bytes, sizeof(Tcl_WideUInt), &numBytes))) { + if (numPtr->sign || (MP_OKAY != mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, numPtr))) { /* * If the sign bit is set (a negative value) or if the value * can't possibly fit in the bits of an unsigned wide, there's @@ -553,16 +548,6 @@ GetUWide( */ return 1; } -#ifndef WORDS_BIGENDIAN - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } -#else /* WORDS_BIGENDIAN */ - /* - * Big-endian can read the value directly. - */ - value = scratch.value; -#endif /* WORDS_BIGENDIAN */ *uwidePtr = value; return 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7af42d3..ad60fc3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -232,6 +232,8 @@ int TclParseArgsObjv(Tcl_Interp *interp, #define TclBN_mp_mul_2d mp_mul_2d #define TclBN_mp_neg mp_neg #define TclBN_mp_or mp_or +#define TclBN_mp_pack mp_pack +#define TclBN_mp_pack_count mp_pack_count #define TclBN_mp_radix_size mp_radix_size #define TclBN_mp_reverse mp_reverse #define TclBN_mp_read_radix mp_read_radix @@ -1325,12 +1327,12 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_get_mag_u64, /* 69 */ TclBN_mp_set_i64, /* 70 */ TclBN_mp_unpack, /* 71 */ - 0, /* 72 */ + TclBN_mp_pack, /* 72 */ TclBN_mp_tc_and, /* 73 */ TclBN_mp_tc_or, /* 74 */ TclBN_mp_tc_xor, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ - 0, /* 77 */ + TclBN_mp_pack_count, /* 77 */ TclBN_mp_to_ubin, /* 78 */ TclBN_mp_div_ld, /* 79 */ TclBN_mp_to_radix, /* 80 */ diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 3a3b9a8..27c4f98 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -247,6 +247,10 @@ declare 71 { mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) } +declare 72 { + mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, + size_t size, mp_endian endian, size_t nails, const mp_int *op) +} # Added in libtommath 1.1.0 declare 73 {deprecated {merged with mp_and}} { @@ -261,6 +265,9 @@ declare 75 {deprecated {merged with mp_xor}} { declare 76 { mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } +declare 77 { + size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size) +} # Added in libtommath 1.2.0 declare 78 { diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 8d12adf..009f914 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -125,6 +125,8 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_mul_2d TclBN_mp_mul_2d #define mp_neg TclBN_mp_neg #define mp_or TclBN_mp_or +#define mp_pack TclBN_mp_pack +#define mp_pack_count TclBN_mp_pack_count #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd @@ -394,7 +396,11 @@ EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; -/* Slot 72 is reserved */ +/* 72 */ +EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount, + size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, + const mp_int *op) MP_WUR; /* 73 */ TCL_DEPRECATED("merged with mp_and") mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, @@ -410,7 +416,9 @@ mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, /* 76 */ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; -/* Slot 77 is reserved */ +/* 77 */ +EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, + size_t size) MP_WUR; /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; @@ -497,12 +505,12 @@ typedef struct TclTomMathStubs { uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */ - void (*reserved72)(void); + mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */ TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */ - void (*reserved77)(void); + size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */ mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */ @@ -664,7 +672,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */ #define TclBN_mp_unpack \ (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ -/* Slot 72 is reserved */ +#define TclBN_mp_pack \ + (tclTomMathStubsPtr->tclBN_mp_pack) /* 72 */ #define TclBN_mp_tc_and \ (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ #define TclBN_mp_tc_or \ @@ -673,7 +682,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ -/* Slot 77 is reserved */ +#define TclBN_mp_pack_count \ + (tclTomMathStubsPtr->tclBN_mp_pack_count) /* 77 */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ #define TclBN_mp_div_ld \ diff --git a/unix/Makefile.in b/unix/Makefile.in index c1bfca5..edcb010 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,9 +335,9 @@ TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ bn_mp_init_i64.o bn_mp_init_u64.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ - bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ - bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_set_i64.o \ - bn_mp_read_radix.o bn_mp_rshd.o \ + bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o \ + bn_mp_pack_count.o bn_mp_radix_size.o bn_mp_radix_smap.o \ + bn_mp_set_i64.o bn_mp_read_radix.o bn_mp_rshd.o \ bn_mp_set_u64.o bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_signed_rsh.o \ @@ -1690,6 +1690,12 @@ bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c $(MATHHDRS) bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c +bn_mp_pack.o: $(TOMMATH_DIR)/bn_mp_pack.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack.c + +bn_mp_pack_count.o: $(TOMMATH_DIR)/bn_mp_pack_count.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack_count.c + bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c diff --git a/win/Makefile.in b/win/Makefile.in index 0035a50..8d28c9e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -401,6 +401,8 @@ TOMMATH_OBJS = \ bn_mp_mul_d.${OBJEXT} \ bn_mp_neg.${OBJEXT} \ bn_mp_or.${OBJEXT} \ + bn_mp_pack.${OBJEXT} \ + bn_mp_pack_count.${OBJEXT} \ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ diff --git a/win/makefile.vc b/win/makefile.vc index f9c9242..e583ae0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -379,6 +379,8 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_mul_d.obj \ $(TMP_DIR)\bn_mp_neg.obj \ $(TMP_DIR)\bn_mp_or.obj \ + $(TMP_DIR)\bn_mp_pack.obj \ + $(TMP_DIR)\bn_mp_pack_count.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ -- cgit v0.12 From 386c7ea2d345ea032e96b2f0085bbaa31b204448 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 11:24:44 +0000 Subject: Since this FIXME! is already fixed, adapt documentation --- doc/LinkVar.3 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 3a41582..6d7ef12 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -239,9 +239,8 @@ The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned -integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be -cast to unsigned); -.\" FIXME! Use bignums instead. +wideinteger form acceptable to \fBTcl_GetBignumFromObj\fR and in the +platform's defined range for the \fBTcl_WideUInt\fR type; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted -- cgit v0.12 From 870cb82c96d74e93a642296f68319c777359a11d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 13:06:59 +0000 Subject: Change all mp_to_ubin() usages to mp_pack(). It makes the code much more clear --- generic/tclObj.c | 34 ++++++++++------------------------ 1 file changed, 10 insertions(+), 24 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index ce8e610..bad3f85 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3124,15 +3124,12 @@ Tcl_GetLongFromObj( { mp_int big; - unsigned long scratch, value = 0; - unsigned char *bytes = (unsigned char *) &scratch; + unsigned long value = 0; size_t numBytes; TclUnpackBignum(objPtr, big); - if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { if (big.sign) { if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = (long)(-value); @@ -3364,14 +3361,10 @@ Tcl_GetWideIntFromObj( mp_int big; Tcl_WideUInt value = 0; size_t numBytes; - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); @@ -3444,21 +3437,18 @@ TclGetWideBitsFromObj( mp_int big; mp_err err; - Tcl_WideUInt value = 0, scratch; + Tcl_WideUInt value = 0; size_t numBytes; - unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); if (err == MP_OKAY) { - err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + err = mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big); } if (err != MP_OKAY) { return TCL_ERROR; } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; mp_clear(&big); return TCL_OK; @@ -3828,19 +3818,15 @@ Tcl_SetBignumObj( { Tcl_WideUInt value = 0; size_t numBytes; - Tcl_WideUInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, bignumValue) != MP_OKAY) { goto tooLargeForWide; } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } -- cgit v0.12 From 9d2a40a82608f1e3d87aac7de2190dfcd92470da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 14:36:01 +0000 Subject: Reserve stub entries 684/685 for TIP #648 and 686 for TIP #650 --- generic/tcl.decls | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6d9fbbd..adaaf7c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2552,7 +2552,22 @@ declare 683 { int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) } -# ----- BASELINE -- FOR -- 8.7.0 ----- # +# TIP #648 (reserved) +#declare 684 { +# Tcl_Obj *Tcl_NewWideUIntObj(Tcl_WideUInt wideValue) +#} +#declare 685 { +# void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue) +#} + +# TIP #650 (reserved) +#declare 686 { +# int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, +# Tcl_WideUInt *uwidePtr) +#} + + +# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # ############################################################################## -- cgit v0.12 From bc7b50deb01ade74b10ba048ed869537d7d8b1d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 22:09:09 +0000 Subject: Make httpd11.tcl work with Tcl 8.6 too --- tests/httpd11.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 55b52fd..b605005 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl +package require Tcl proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { -- cgit v0.12 From c432e303c0b17ee4dde9a3ec3bc1e04c381b32e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 09:37:42 +0000 Subject: http 2.10a4 -> 2.10b1, for upcoming release --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- library/manifest.txt | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index a1d4a2b..1f476f3 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.10a4 +package provide http 2.10b1 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 5437859..8977ef3 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.10a4 [list tclPkgSetup $dir http 2.10a4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.10b1 [list tclPkgSetup $dir http 2.10b1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/manifest.txt b/library/manifest.txt index 6d999e8..cc1e223 100644 --- a/library/manifest.txt +++ b/library/manifest.txt @@ -5,7 +5,7 @@ apply {{dir} { set ::test [info script] set isafe [interp issafe] foreach {safe package version file} { - 0 http 2.10a4 {http http.tcl} + 0 http 2.10b1 {http http.tcl} 1 msgcat 1.7.1 {msgcat msgcat.tcl} 1 opt 0.4.8 {opt optparse.tcl} 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} diff --git a/unix/Makefile.in b/unix/Makefile.in index edcb010..dcaf6e3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1041,9 +1041,9 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done - @echo "Installing package http 2.10a4 as a Tcl Module" + @echo "Installing package http 2.10b1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm" @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ diff --git a/win/Makefile.in b/win/Makefile.in index 8d28c9e..689f9b8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -881,8 +881,8 @@ install-libraries: libraries install-tzdata install-msgs $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; - @echo "Installing package http 2.10a4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm"; + @echo "Installing package http 2.10b1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ -- cgit v0.12 From f9c4e3a8b2291e504e646c00229d5b335ab3aab8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 20:39:34 +0000 Subject: Change 5 functions signatures from int -> size_t. Those should have been part of TIP #494 (Thanks, Gustaf!) --- generic/tcl.decls | 10 +++++----- generic/tclDecls.h | 20 ++++++++++---------- generic/tclUtf.c | 10 +++++----- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 85e5082..da8ea4f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1239,16 +1239,16 @@ declare 333 { const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 334 { - int Tcl_UtfToLower(char *src) + Tcl_Size Tcl_UtfToLower(char *src) } declare 335 { - int Tcl_UtfToTitle(char *src) + Tcl_Size Tcl_UtfToTitle(char *src) } declare 336 { - int Tcl_UtfToChar16(const char *src, unsigned short *chPtr) + Tcl_Size Tcl_UtfToChar16(const char *src, unsigned short *chPtr) } declare 337 { - int Tcl_UtfToUpper(char *src) + Tcl_Size Tcl_UtfToUpper(char *src) } declare 338 { Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen) @@ -2454,7 +2454,7 @@ declare 645 { # TIP #548 declare 646 { - int Tcl_UtfToUniChar(const char *src, int *chPtr) + Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { char *Tcl_UniCharToUtfDString(const int *uniStr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8e4aa59..eebdb64 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -888,14 +888,14 @@ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 334 */ -EXTERN int Tcl_UtfToLower(char *src); +EXTERN Tcl_Size Tcl_UtfToLower(char *src); /* 335 */ -EXTERN int Tcl_UtfToTitle(char *src); +EXTERN Tcl_Size Tcl_UtfToTitle(char *src); /* 336 */ -EXTERN int Tcl_UtfToChar16(const char *src, +EXTERN Tcl_Size Tcl_UtfToChar16(const char *src, unsigned short *chPtr); /* 337 */ -EXTERN int Tcl_UtfToUpper(char *src); +EXTERN Tcl_Size Tcl_UtfToUpper(char *src); /* 338 */ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen); @@ -1735,7 +1735,7 @@ EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 646 */ -EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); +EXTERN Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); @@ -2197,10 +2197,10 @@ typedef struct TclStubs { const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 333 */ - int (*tcl_UtfToLower) (char *src); /* 334 */ - int (*tcl_UtfToTitle) (char *src); /* 335 */ - int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ - int (*tcl_UtfToUpper) (char *src); /* 337 */ + Tcl_Size (*tcl_UtfToLower) (char *src); /* 334 */ + Tcl_Size (*tcl_UtfToTitle) (char *src); /* 335 */ + Tcl_Size (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ + Tcl_Size (*tcl_UtfToUpper) (char *src); /* 337 */ Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ @@ -2509,7 +2509,7 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */ int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */ - int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e882f18..77a7cf2 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -447,7 +447,7 @@ static const unsigned short cp1252[32] = { }; #undef Tcl_UtfToUniChar -int +size_t Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ int *chPtr)/* Filled with the Unicode character represented by @@ -530,7 +530,7 @@ Tcl_UtfToUniChar( return 1; } -int +size_t Tcl_UtfToChar16( const char *src, /* The UTF-8 string. */ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by @@ -1335,7 +1335,7 @@ Tcl_UtfBackslash( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToUpper( char *str) /* String to convert in place. */ { @@ -1388,7 +1388,7 @@ Tcl_UtfToUpper( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToLower( char *str) /* String to convert in place. */ { @@ -1442,7 +1442,7 @@ Tcl_UtfToLower( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToTitle( char *str) /* String to convert in place. */ { -- cgit v0.12 From 197060f0971c7ba1c3148200b4c90fb0fa430859 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 20:52:30 +0000 Subject: one more (Tcl_UniCharToUtf), and adapt documentation --- doc/ToUpper.3 | 6 +++--- doc/Utf.3 | 8 ++++---- generic/tcl.decls | 2 +- generic/tclDecls.h | 12 ++++++------ generic/tclUtf.c | 2 +- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index 37ebd2b..86d2f98 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -22,13 +22,13 @@ int int \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp -int +size_t \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp -int +size_t \fBTcl_UtfToLower\fR(\fIstr\fR) .sp -int +size_t \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out diff --git a/doc/Utf.3 b/doc/Utf.3 index 514c2dc..31cc333 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -15,16 +15,16 @@ Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar .sp typedef ... \fBTcl_UniChar\fR; .sp -int +size_t \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp -int +size_t \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp -int +size_t \fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR) .sp -int +size_t \fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR) .sp char * diff --git a/generic/tcl.decls b/generic/tcl.decls index da8ea4f..3fb1a43 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1205,7 +1205,7 @@ declare 323 { int Tcl_UniCharToUpper(int ch) } declare 324 { - int Tcl_UniCharToUtf(int ch, char *buf) + Tcl_Size Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { const char *TclUtfAtIndex(const char *src, Tcl_Size index) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index eebdb64..90105bc 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -860,7 +860,7 @@ EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ -EXTERN int Tcl_UniCharToUtf(int ch, char *buf); +EXTERN Tcl_Size Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); /* 326 */ @@ -2187,7 +2187,7 @@ typedef struct TclStubs { int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ - int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ + Tcl_Size (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ @@ -4128,8 +4128,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) @@ -4169,8 +4169,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 77a7cf2..92bcf4f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -209,7 +209,7 @@ Invalid( */ #undef Tcl_UniCharToUtf -int +size_t Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. Can be or'ed with flag TCL_COMBINE */ -- cgit v0.12 From 00c7d174e45b9a5f10dc0de803dc98c4f1490061 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 17 Nov 2022 03:52:45 +0000 Subject: Reserve stub entry 687 for TIP #651 --- generic/tcl.decls | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index adaaf7c..3f4103f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2566,6 +2566,10 @@ declare 683 { # Tcl_WideUInt *uwidePtr) #} +# TIP 651 (reserved) +#declare 687 { +# Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) +#} # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # -- cgit v0.12 From 8b9fe0fa5355f282642f092c269ffa174813ba73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Nov 2022 11:18:51 +0000 Subject: doc update --- doc/OpenFileChnl.3 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 4e42b93..e8ed521 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -406,10 +406,10 @@ to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the -return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that +return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. .PP -Setting \fIcharsToRead\fR to \fB\-1\fR will cause the command to read +Setting \fIcharsToRead\fR to TCL_INDEX_NONE will cause the command to read all characters currently available (non-blocking) or everything until eof (blocking mode). .PP @@ -471,14 +471,14 @@ character(s) are read and discarded. .PP If a line was successfully read, the return value is greater than or equal to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an -error occurs, \fBTcl_GetsObj\fR returns \-1 and records a POSIX error code +error occurs, \fBTcl_GetsObj\fR returns TCL_INDEX_NONE and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also -returns \-1 if the end of the file is reached; the \fBTcl_Eof\fR procedure +returns TCL_INDEX_NONE if the end of the file is reached; the \fBTcl_Eof\fR procedure can be used to distinguish an error from an end-of-file condition. .PP -If the channel is in nonblocking mode, the return value can also be \-1 if -no data was available or the data that was available did not contain an -end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR +If the channel is in nonblocking mode, the return value can also be TCL_INDEX_NONE +if no data was available or the data that was available did not contain an +end-of-line character. When TCL_INDEX_NONE is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP @@ -496,7 +496,7 @@ head of the queue. If \fIchannel\fR has a .QW sticky EOF set, no data will be added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or -\-1 if an error occurs. +TCL_INDEX_NONE if an error occurs. .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at @@ -513,10 +513,10 @@ to appear as soon as a complete line is accepted for output, set the \fB\-buffering\fR option on the channel to \fBline\fR mode. .PP The return value of \fBTcl_WriteChars\fR is a count of how many bytes were -accepted for output to the channel. This is either greater than zero to -indicate success or \-1 to indicate that an error occurred. If an error -occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be -retrieved with \fBTcl_GetErrno\fR. +accepted for output to the channel. This is either TCL_INDEX_NONE to +indicate that an error occurred or another number greater than +zero to indicate success. If an error occurs, \fBTcl_WriteChars\fR records +a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the -- cgit v0.12 From b669079dd69a6f5b0027edd74d53f8b0390769f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Nov 2022 20:24:20 +0000 Subject: Add dummy TCL_OBJTYPE_V0 #define. Minimal no-op backport of TIP #644 --- generic/tcl.h | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tcl.h b/generic/tcl.h index e705cdb..800ffa1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -752,6 +752,7 @@ typedef struct Tcl_ObjType { * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; +#define TCL_OBJTYPE_V0 /* just empty */ /* * The following structure stores an internal representation (internalrep) for -- cgit v0.12